' Copyright 2008 ESRI
'
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
'
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
'
' See use restrictions at <your ArcGIS install location>/developerkit/userestrictions.txt.
'
Option Explicit
Private Const mFormWidth As Long = 9550
Private Const mFormHeight As Long = 7080
Private mApplication As esriFramework.IApplication
Private mGeometricNetwork As esriGeoDatabase.IGeometricNetwork
Private mMouseClick As Boolean
Private Const MODULE_NAME As String = "frmGeometricNetwork.frm"
Public Sub Init(ByRef pApplication As esriFramework.IApplication)
On Error GoTo ErrorHandler
'-----------------------
' Set Modular Variables
'-----------------------
Set mApplication = pApplication
'---------------
' Set Variables
'---------------
mMouseClick = False
'-----------
' Load Form
'-----------
Load Me
'--------------
' Display Form
'--------------
Me.Show vbModeless
'
Exit Sub
ErrorHandler:
Call HandleError(False, "Init " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdApply_Click()
On Error GoTo ErrorHandler
'------------------------------------------------------------------------------------
' This procedure will update the connectivity rules in the selected GeometricNetwork
'------------------------------------------------------------------------------------
Dim pJunctionConnectivityRule2 As esriGeoDatabase.IJunctionConnectivityRule2
Dim pEdgeConnectivityRule As esriGeoDatabase.IEdgeConnectivityRule
Dim pFeatureClassContainer As esriGeoDatabase.IFeatureClassContainer
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
'
Dim pIndexRow As Long
Dim pIndexCol As Long
Dim pStartCol As Long
Dim pStartRow As Long
'
Dim pEdge1 As String
Dim pEdgeSubtype1 As String
Dim pEdge2 As String
Dim pEdgeSubtype2 As String
Dim pJunction As String
Dim pJunctionSubtype As String
'
Dim pCardinality As String
'---------------------
' Change Mouse Cursor
'---------------------
Me.MousePointer = vbHourglass
Me.flexEE.MousePointer = vbHourglass
Me.flexEJ.MousePointer = vbHourglass
'----------------------------------------------
' First Remove all Existing Connectivity Rules
'----------------------------------------------
Call UpdateStatusBar("Deleting All Existing Rules")
Call modImportExport.RemoveConnectivityRules(mGeometricNetwork)
'------------------------------------------------------------------------------------------------------
' QI to IFeatureClassContainer. This will be used to get the ObjectClass ID from the FeatureClass name
'------------------------------------------------------------------------------------------------------
Set pFeatureClassContainer = mGeometricNetwork
'-------------------------------------
' Add New Junction Connectivity Rules
'-------------------------------------
Me.flexEJ.Redraw = False
pStartCol = Me.flexEJ.Col
pStartRow = Me.flexEJ.Row
'
For pIndexRow = 3 To Me.flexEJ.Rows - 1 Step 1
Me.flexEJ.Row = pIndexRow
'------------------------------------------
' Get Edge and Junction FeatureClass Names
'------------------------------------------
pEdge1 = Me.flexEJ.TextMatrix(pIndexRow, 0)
pEdgeSubtype1 = Me.flexEJ.TextMatrix(pIndexRow, 1)
For pIndexCol = 2 To Me.flexEJ.Cols - 1 Step 1
Me.flexEJ.Col = pIndexCol
'
If Me.flexEJ.CellFontStrikeThrough Then
'---------
' No Rule
'---------
Else
'---------------------------------
' Get Junction FeatureClass Names
'---------------------------------
pJunction = Me.flexEJ.TextMatrix(1, pIndexCol)
pJunctionSubtype = Me.flexEJ.TextMatrix(2, pIndexCol)
'
Set pJunctionConnectivityRule2 = New JunctionConnectivityRule
'-----------------------------------
' Set Edge FeatureClass and Subtype
'-----------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pEdge1)
pJunctionConnectivityRule2.EdgeClassID = pFeatureClass.FeatureClassID
pJunctionConnectivityRule2.EdgeSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pEdgeSubtype1)
'---------------------------------------
' Set Junction FeatureClass and Subtype
'---------------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pJunction)
pJunctionConnectivityRule2.JunctionClassID = pFeatureClass.FeatureClassID
pJunctionConnectivityRule2.JunctionSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pJunctionSubtype)
'-----------------------------------
' Set Edge and Junction Cardinality
'-----------------------------------
pCardinality = Me.flexEJ.TextMatrix(pIndexRow, pIndexCol)
'
If pCardinality = "" Then
pJunctionConnectivityRule2.EdgeMinimumCardinality = -1
pJunctionConnectivityRule2.EdgeMaximumCardinality = -1
pJunctionConnectivityRule2.JunctionMinimumCardinality = -1
pJunctionConnectivityRule2.JunctionMaximumCardinality = -1
Else
If CStr(Mid(pCardinality, 6, 1)) = "*" Then
pJunctionConnectivityRule2.EdgeMinimumCardinality = -1
pJunctionConnectivityRule2.EdgeMaximumCardinality = -1
Else
pJunctionConnectivityRule2.EdgeMinimumCardinality = CLng(Mid(pCardinality, 3, 1))
pJunctionConnectivityRule2.EdgeMaximumCardinality = CLng(Mid(pCardinality, 6, 1))
End If
If CStr(Mid(pCardinality, 13, 1)) = "*" Then
pJunctionConnectivityRule2.JunctionMinimumCardinality = -1
pJunctionConnectivityRule2.JunctionMaximumCardinality = -1
Else
pJunctionConnectivityRule2.JunctionMinimumCardinality = CLng(Mid(pCardinality, 10, 1))
pJunctionConnectivityRule2.JunctionMaximumCardinality = CLng(Mid(pCardinality, 13, 1))
End If
End If
'----------------------
' Set Default Junction
'----------------------
If Me.flexEJ.CellFontBold Then
pJunctionConnectivityRule2.DefaultJunction = True
End If
'------------------------------
' Add Rule to GeometricNetwork
'------------------------------
Call mGeometricNetwork.AddRule(pJunctionConnectivityRule2)
Call UpdateStatusBar("Adding Junction Rule: " & pJunctionConnectivityRule2.ID)
End If
Next pIndexCol
Next pIndexRow
'
Me.flexEJ.Redraw = True
Me.flexEJ.Col = pStartCol
Me.flexEJ.Row = pStartRow
'---------------------------------
' Add New Edge Connectivity Rules
'---------------------------------
Me.flexEE.Redraw = False
pStartCol = Me.flexEE.Col
pStartRow = Me.flexEE.Row
'
For pIndexRow = 3 To Me.flexEE.Rows - 1 Step 1
Me.flexEE.Row = pIndexRow
'-----------------------------
' Get Edge FeatureClass Names
'-----------------------------
pEdge1 = Me.flexEE.TextMatrix(pIndexRow, 0)
pEdgeSubtype1 = Me.flexEE.TextMatrix(pIndexRow, 1)
pEdge2 = Me.flexEE.TextMatrix(pIndexRow, 2)
pEdgeSubtype2 = Me.flexEE.TextMatrix(pIndexRow, 3)
'
Set pEdgeConnectivityRule = New esriGeoDatabase.EdgeConnectivityRule
'----------------------------------------
' Set From Edge FeatureClass and Subtype
'----------------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pEdge1)
pEdgeConnectivityRule.FromEdgeClassID = pFeatureClass.FeatureClassID
pEdgeConnectivityRule.FromEdgeSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pEdgeSubtype1)
'--------------------------------------
' Set To Edge FeatureClass and Subtype
'--------------------------------------
Set pFeatureClass = pFeatureClassContainer.ClassByName(pEdge2)
pEdgeConnectivityRule.ToEdgeClassID = pFeatureClass.FeatureClassID
pEdgeConnectivityRule.ToEdgeSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pEdgeSubtype2)
'
For pIndexCol = 4 To Me.flexEE.Cols - 1 Step 1
Me.flexEE.Col = pIndexCol
'
If Me.flexEE.CellBackColor = RGB(192, 192, 192) Then
Exit For
End If
'
If Me.flexEE.CellFontStrikeThrough Then
'---------
' No Rule
'---------
Else
'---------------------------------
' Get Junction FeatureClass Names
'---------------------------------
pJunction = Me.flexEE.TextMatrix(1, pIndexCol)
pJunctionSubtype = Me.flexEE.TextMatrix(2, pIndexCol)
'
Set pFeatureClass = pFeatureClassContainer.ClassByName(pJunction)
'----------------------------------------
' Add Junction/Subtype to Edge-Edge Rule
'----------------------------------------
Call pEdgeConnectivityRule.AddJunction(pFeatureClass.FeatureClassID, GetSubtypeCodeFromName(pFeatureClass, pJunctionSubtype))
If Me.flexEE.CellFontBold Then
pEdgeConnectivityRule.DefaultJunctionClassID = pFeatureClass.FeatureClassID
pEdgeConnectivityRule.DefaultJunctionSubtypeCode = GetSubtypeCodeFromName(pFeatureClass, pJunctionSubtype)
End If
End If
Next pIndexCol
'------------------------------------------------
' Add Edge Connectivity Rule to GeometricNetwork
'------------------------------------------------
If pEdgeConnectivityRule.JunctionCount = 0 Then
Set pEdgeConnectivityRule = Nothing
Else
Call mGeometricNetwork.AddRule(pEdgeConnectivityRule)
Call UpdateStatusBar("Adding Edge Rule: " & pEdgeConnectivityRule.ID)
End If
Next pIndexRow
'
Me.flexEE.Redraw = True
Me.flexEE.Col = pStartCol
Me.flexEE.Row = pStartRow
'---------------------
' Restore MouseCursor
'---------------------
'Set pMouseCursor = Nothing
Me.MousePointer = vbDefault
Me.flexEE.MousePointer = vbDefault
Me.flexEJ.MousePointer = vbDefault
'----------------------
' Disable Apply Button
'----------------------
Me.cmdApply.Enabled = False
'------------------
' Clear Status Bar
'------------------
Call UpdateStatusBar("")
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdApply_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdClose_Click()
On Error GoTo ErrorHandler
'
Unload Me
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdClose_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdEEClear_Click()
On Error GoTo ErrorHandler
'
Call BulkUpdateRules(Me.flexEE, False)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdEEClear_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdEJClear_Click()
On Error GoTo ErrorHandler
'
Call BulkUpdateRules(Me.flexEJ, False)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdEJClear_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdEEAll_Click()
On Error GoTo ErrorHandler
'
Call BulkUpdateRules(Me.flexEE, True)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdEEAll_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdEJAll_Click()
On Error GoTo ErrorHandler
'
Call BulkUpdateRules(Me.flexEJ, True)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdEJAll_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub BulkUpdateRules(ByRef pMSHFlexGrid As MSHierarchicalFlexGridLib.MSHFlexGrid, _
ByRef pOperation As Boolean)
On Error GoTo ErrorHandler
'-----------------------------------------------------------------
' Build Clear or Add Rules for a FlexGrid (EE or EJ Rules)
' OPERATIONS: Clear (pOperation = FALSE), Add (pOperation = TRUE)
'-----------------------------------------------------------------
Dim pStartCol As Long
Dim pStartRow As Long
Dim pIndexCol As Long
Dim pIndexRow As Long
Dim pIndexColClick As Long
Dim pIndexRowClick As Long
'--------------------------
' Turn Off FlexGrid Redraw
'--------------------------
pMSHFlexGrid.Redraw = False
'
pIndexColClick = pMSHFlexGrid.Col
pIndexRowClick = pMSHFlexGrid.Row
'
Select Case Me.TabStrip1.SelectedItem.Index
Case 2
pStartCol = 4
pStartRow = 3
Case 3
pStartCol = 2
pStartRow = 3
Case Else
MsgBox "ERROR: Incorrect TabStrip Index", vbCritical
Exit Sub
End Select
'-----------------------
' Iterate Left to Right
'-----------------------
For pIndexRow = pStartRow To pMSHFlexGrid.Rows - 1 Step 1
pMSHFlexGrid.Row = pIndexRow
'-----------------------
' Iterate Top to Bottom
'-----------------------
For pIndexCol = pStartCol To pMSHFlexGrid.Cols - 1 Step 1
pMSHFlexGrid.Col = pIndexCol
'
If pMSHFlexGrid.CellBackColor = RGB(192, 192, 192) Then
Exit For
End If
'
If pOperation Then
If pMSHFlexGrid.CellFontStrikeThrough Then
'-----------
' Check Box
'-----------
pMSHFlexGrid.CellFontStrikeThrough = False
pMSHFlexGrid.Text = ""
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
'-----------------------------------
' Assign Cardinality if not present
'-----------------------------------
If Me.TabStrip1.SelectedItem.Index = 3 Then
pMSHFlexGrid.Text = "E:" & "0" & ".." & "*" & Chr(13) & "J:" & "0" & ".." & "*"
End If
'------------------------------
' Explicitly Add Junction Rule
'------------------------------
Call ExplicitlyAddEJRule
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
Else
'------------------------
' Already Checked - Skip
'------------------------
End If
Else
pMSHFlexGrid.CellFontStrikeThrough = True
pMSHFlexGrid.Text = ""
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_OFF", 0)
End If
'
Next pIndexCol
Next pIndexRow
'-------------------------
' Turn On FlexGrid Redraw
'-------------------------
pMSHFlexGrid.Redraw = True
'-------------------------------
' Reset the selected Row/Column
'-------------------------------
pMSHFlexGrid.Col = pIndexColClick
pMSHFlexGrid.Row = pIndexRowClick
'-------------------------
' Enable the Apply Button
'-------------------------
Me.cmdApply.Enabled = True
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ClearRules " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdEEKeys_Click()
On Error GoTo ErrorHandler
'
Call frmKeys.Init
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdEEKeys_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdEJKeys_Click()
On Error GoTo ErrorHandler
'
Call frmKeys.Init
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdEJKeys_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdHelp_Click()
On Error GoTo ErrorHandler
'
Call modCommon.LaunchHelp
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdHelp_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error GoTo ErrorHandler
'
Dim Msg As String
'
If Me.cmdApply.Enabled Then
If UnloadMode > 0 Then
'----------------------------
' If exiting the application.
'----------------------------
Msg = "Connectivity Rules have been modified. Do you really want to exit without saving?"
Else
'----------------------------
' If just closing the form.
'----------------------------
Msg = "Connectivity Rules have been modified. Do you really want to exit without saving?"
End If
'------------------------------------------------
' If user clicks the No button, stop QueryUnload.
'------------------------------------------------
If MsgBox(Msg, vbQuestion + vbYesNo, Me.CAPTION) = vbNo Then
Cancel = True
End If
End If
'
Exit Sub
ErrorHandler:
Call HandleError(True, "Form_QueryUnload " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub Form_Load()
On Error GoTo ErrorHandler
'
Dim pColumnHeader As ColumnHeader
'------
' Form
'------
Me.CAPTION = "GeometricNetwork Connectivity Rule Editor"
Me.Height = mFormHeight
Me.Width = mFormWidth
'--------
' Frames
'--------
Me.fmeEE.Left = Me.fmeGeometricNetworkName.Left
Me.fmeEE.Top = Me.fmeGeometricNetworkName.Top
Me.fmeEJ.Left = Me.fmeGeometricNetworkName.Left
Me.fmeEJ.Top = Me.fmeGeometricNetworkName.Top
'------------
' Status Bar
'------------
Me.StatusBar1.Style = sbrSimple
'-----------------
' GN Name TextBox
'-----------------
Me.txtGeomtricNetworkName.Text = ""
'-----------
' TreeView
'-----------
Me.lvwNetworkClass.View = lvwReport
Me.lvwNetworkClass.Checkboxes = False 'True
Me.lvwNetworkClass.Sorted = True
Me.lvwNetworkClass.LabelEdit = lvwManual
Me.lvwNetworkClass.GridLines = False
Me.lvwNetworkClass.AllowColumnReorder = False
Set pColumnHeader = Me.lvwNetworkClass.ColumnHeaders.Add(, , "FeatureClass(s)", CSng(3500))
Set pColumnHeader = Me.lvwNetworkClass.ColumnHeaders.Add(, , "Feature Type", CSng(2000))
Set pColumnHeader = Me.lvwNetworkClass.ColumnHeaders.Add(, , "Ancillary Role", CSng(2000))
'---------------
' FlexGrid - EE
'---------------
Me.flexEE.AllowBigSelection = False
Me.flexEE.AllowUserResizing = flexResizeColumns
Me.flexEE.Appearance = flex3D
Me.flexEE.FocusRect = flexFocusHeavy
Me.flexEE.MergeCells = flexMergeRestrictAll
Me.flexEE.RowSizingMode = flexRowSizeIndividual
Me.flexEE.ScrollBars = flexScrollBarBoth
Me.flexEE.ScrollTrack = True
Me.flexEE.TextStyle = flexTextFlat
Me.flexEE.TextStyleFixed = flexTextFlat
Me.flexEE.WordWrap = False
'
Me.flexEE.Cols = 5
Me.flexEE.Rows = 4
Me.flexEE.FixedCols = 4
Me.flexEE.FixedRows = 3
'
Me.flexEE.MergeCol(0) = True
Me.flexEE.MergeCol(1) = True
Me.flexEE.MergeCol(2) = True
Me.flexEE.MergeCol(3) = True
Me.flexEE.MergeRow(0) = True
Me.flexEE.MergeRow(1) = True
Me.flexEE.MergeRow(2) = True
'---------------
' FlexGrid - EJ
'---------------
Me.flexEJ.AllowBigSelection = False
Me.flexEJ.AllowUserResizing = flexResizeColumns
Me.flexEJ.Appearance = flex3D
Me.flexEJ.FocusRect = flexFocusHeavy
Me.flexEJ.MergeCells = flexMergeRestrictAll
Me.flexEJ.RowSizingMode = flexRowSizeIndividual
Me.flexEJ.ScrollBars = flexScrollBarBoth
Me.flexEJ.ScrollTrack = True
Me.flexEJ.TextStyle = flexTextFlat
Me.flexEJ.TextStyleFixed = flexTextFlat
Me.flexEJ.WordWrap = True
'
Me.flexEJ.Cols = 3
Me.flexEJ.Rows = 4
Me.flexEJ.FixedCols = 2
Me.flexEJ.FixedRows = 3
'
Me.flexEJ.MergeCol(0) = True
Me.flexEJ.MergeCol(1) = True
Me.flexEJ.MergeRow(0) = True
Me.flexEJ.MergeRow(1) = True
Me.flexEJ.MergeRow(2) = True
'---------
' Buttons
'---------
Me.cmdApply.Enabled = False
'-------------
' Slider - EE
'-------------
Me.sldEEWidth.BorderStyle = ccFixedSingle
Me.sldEEWidth.LargeChange = 100
Me.sldEEWidth.Max = 2000
Me.sldEEWidth.Min = 500
Me.sldEEWidth.Orientation = ccOrientationHorizontal
Me.sldEEWidth.SmallChange = 50
Me.sldEEWidth.TextPosition = sldAboveLeft
Me.sldEEWidth.TickFrequency = 200
Me.sldEEWidth.Value = 1000
'-------------
' Slider - EJ
'-------------
Me.sldEJWidth.BorderStyle = ccFixedSingle
Me.sldEJWidth.LargeChange = 100
Me.sldEJWidth.Max = 2000
Me.sldEJWidth.Min = 700
Me.sldEJWidth.Orientation = ccOrientationHorizontal
Me.sldEJWidth.SmallChange = 50
Me.sldEJWidth.TextPosition = sldAboveLeft
Me.sldEJWidth.TickFrequency = 200
Me.sldEJWidth.Value = 1000
'-----------------
' CheckBoxes - EE
'-----------------
Me.chkEEShowEdgeSubtype.Value = vbChecked
Me.chkEEShowJunctionSubtype.Value = vbChecked
Me.chkEJShowEdgeSubtype.Value = vbChecked
Me.chkEJShowJunctionSubtype.Value = vbChecked
Me.chkEJPersist.Value = vbUnchecked
Me.chkEEAutoCreateEJRule.Value = vbChecked
'-------------------
' Cardinality Frame
'-------------------
Call PopulateComboBox(Me.cboEmin, 0, 9)
Call PopulateComboBox(Me.cboEmax, 0, 9)
Call PopulateComboBox(Me.cboJmin, 0, 9)
Call PopulateComboBox(Me.cboJmax, 0, 9)
'-----------
' TAb Strip
'-----------
Call ClickTabStrip
'------------------
' Disable Controls
'------------------
Call EnableFrame(Me.fmeGeometricNetworkName, False)
Call EnableFrame(Me.fmeNetworkClass, False)
Call EnableFrame(Me.fmeEE, False)
Call EnableFrame(Me.fmeEJ, False)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "Form_Load " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub PopulateComboBox(ByRef pComboBox As VB.ComboBox, ByRef pStart As Long, ByRef pEnd As Long)
On Error GoTo ErrorHandler
'
Dim pIndex As Long
'
pComboBox.Clear
pComboBox.AddItem "-"
For pIndex = pStart To pEnd Step 1
pComboBox.AddItem CStr(pIndex)
Next pIndex
'
pComboBox.Text = "-"
'
Exit Sub
ErrorHandler:
Call HandleError(False, "PopulateComboBox " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub Form_Resize()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
If Me.WindowState = 1 Then
Exit Sub
End If
'
Call PositionFormControls
'
Exit Sub
ErrorHandler:
Call HandleError(True, "Form_Resize " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub PositionFormControls()
On Error GoTo ErrorHandler
'
Me.AutoRedraw = False
'
If Me.Width < mFormWidth Then
Me.Width = mFormWidth
End If
If Me.Height < mFormHeight Then
Me.Height = mFormHeight
End If
'-----------
' Tab Strip
'-----------
Me.TabStrip1.Height = Me.Height - 1185
Me.TabStrip1.Width = Me.Width - 135
'--------
' Frames
'--------
Me.fmeGeometricNetworkName.Width = Me.Width - 375
Me.fmeNetworkClass.Height = Me.Height - 2385
Me.fmeNetworkClass.Width = Me.Width - 375
'
Me.fmeEE.Height = Me.Height - 1665
Me.fmeEE.Width = Me.Width - 375
Me.fmeEJ.Height = Me.Height - 1665
Me.fmeEJ.Width = Me.Width - 375
'
Me.fmeEECellWidth.Top = Me.Height - 2520
Me.fmeEEDisplay.Top = Me.Height - 2520
Me.fmeEERules.Top = Me.Height - 2520
Me.fmeEESettings.Top = Me.Height - 2520
'
Me.fmeEJCellWidth.Top = Me.Height - 2520
Me.fmeEJDisplay.Top = Me.Height - 2520
Me.fmeEJRules.Top = Me.Height - 2520
Me.fmeEJCardinality.Top = Me.Height - 2520
'-------------------
' ListView/FlexGrid
'-------------------
Me.lvwNetworkClass.Height = Me.Height - 2745
Me.lvwNetworkClass.Width = Me.Width - 615
Me.flexEE.Height = Me.Height - 2745
Me.flexEE.Width = Me.Width - 615
Me.flexEJ.Height = Me.Height - 2745
Me.flexEJ.Width = Me.Width - 615
'------
' Text
'------
Me.txtGeomtricNetworkName.Width = Me.Width - 615
'--------
' Button
'--------
Me.cmdLoad.Top = Me.Height - 1080
Me.cmdApply.Left = Me.Width - (1500 + 1135 + 120 + 1135 + 120 + 120 + 120)
Me.cmdApply.Top = Me.Height - 1080
Me.cmdClose.Left = Me.Width - (1500 + 1135 + 120 + 120)
Me.cmdClose.Top = Me.Height - 1080
Me.cmdHelp.Left = Me.Width - 1500
Me.cmdHelp.Top = Me.Height - 1080
'
Me.AutoRedraw = True
'
Exit Sub
ErrorHandler:
Call HandleError(False, "PositionFormControls " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cmdLoad_Click()
On Error GoTo ErrorHandler
'-------------------------
' Get Source XML Document
'-------------------------
Dim pXMLDocumentTemp As MSXML2.DOMDocument
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeGeometricNetwork As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeFeatureClass As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeJunctionConnectivityRule As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeEdgeConnectivityRule As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeListFeatureClass As MSXML2.IXMLDOMNodeList
'
Dim pGxApplication As esriCatalogUI.IGxApplication
Dim pGxObject As esriCatalog.IGxObject
Dim pGxDataset As esriCatalog.IGxDataset
Dim pDatasetGN As esriGeoDatabase.IDataset
Dim pDatasetFC As esriGeoDatabase.IDataset
Dim pFeatureClassContainer As IFeatureClassContainer
Dim pFeatureClass As IFeatureClass
Dim pNetworkClass As INetworkClass
Dim pSubtypes As esriGeoDatabase.ISubtypes
Dim pEnumSubtype As esriGeoDatabase.IEnumSubtype
'
Dim pEnumRule As esriGeoDatabase.IEnumRule
Dim pRule As esriGeoDatabase.IRule
'
Dim pJunctionConnectivityRule2 As esriGeoDatabase.IJunctionConnectivityRule2
Dim pFeatureClassEdge As esriGeoDatabase.IFeatureClass
Dim pFeatureClassJunction As esriGeoDatabase.IFeatureClass
Dim pDatasetEdge As esriGeoDatabase.IDataset
Dim pDatasetJunction As esriGeoDatabase.IDataset
Dim pSubtypesEdge As esriGeoDatabase.ISubtypes
Dim pSubtypesJunction As esriGeoDatabase.ISubtypes
Dim pSubtypeNameEdge As String
Dim pSubtypeNameJunction As String
'
Dim pEdgeConnectivityRule As esriGeoDatabase.IEdgeConnectivityRule
Dim pFeatureClassEdge1 As esriGeoDatabase.IFeatureClass
Dim pFeatureClassEdge2 As esriGeoDatabase.IFeatureClass
Dim pDatasetEdge1 As esriGeoDatabase.IDataset
Dim pDatasetEdge2 As esriGeoDatabase.IDataset
Dim pSubtypesEdge1 As esriGeoDatabase.ISubtypes
Dim pSubtypesEdge2 As esriGeoDatabase.ISubtypes
Dim pSubtypeEdgeName1 As String
Dim pSubtypeEdgeName2 As String
Dim pSubtypeJunctionName As String
Dim pJunctionCounter As Long
'
Dim pListItems As ListItems
Dim pListItem As ListItem
'
Dim pSubtypeCode As Long
Dim pSubtypeName As String
Dim pFeatureTypeLong As String
Dim pFeatureTypeShort As String
Dim pIndex As Long
Dim pIndexRow As Long
Dim pIndexCol As Long
'
Dim pIndexRowFrom As Long
Dim pIndexRowTo As Long
Dim pRowCount As Long
'----------------------
' Get GeometricNetwork
'----------------------
Set pGxApplication = mApplication
Set pGxObject = pGxApplication.SelectedObject
'
If TypeOf pGxObject Is esriCatalog.IGxDataset Then
Set pGxDataset = pGxObject
If pGxDataset.Type = esriDTGeometricNetwork Then
Set pDatasetGN = pGxDataset.Dataset
Set mGeometricNetwork = pDatasetGN
Else
MsgBox "Please select a GeometricNetwork", vbExclamation, App.FileDescription
Exit Sub
End If
Else
MsgBox "Please select a GeometricNetwork", vbExclamation, App.FileDescription
Exit Sub
End If
'-----------------
' Display GN Name
'-----------------
Me.txtGeomtricNetworkName.Text = CStr(pDatasetGN.Name)
Me.txtGeomtricNetworkName.Locked = True
'-------------------------------------------------
' Add Simple and Complex Edges to Horizontal Axis
'-------------------------------------------------
Set pFeatureClassContainer = mGeometricNetwork
'
Set pListItems = Me.lvwNetworkClass.ListItems
pListItems.Clear
'
For pIndex = 0 To pFeatureClassContainer.ClassCount - 1 Step 1
Set pFeatureClass = pFeatureClassContainer.Class(pIndex)
Set pNetworkClass = pFeatureClass
Set pDatasetFC = pFeatureClass
'--------------------------------
' Add FeatureClass(s) to ListBox
'--------------------------------
Select Case CLng(pFeatureClass.FeatureType)
Case esriGeoDatabase.esriFeatureType.esriFTSimpleJunction
pFeatureTypeLong = "Simple Junction"
pFeatureTypeShort = "Junction"
Case esriGeoDatabase.esriFeatureType.esriFTSimpleEdge
pFeatureTypeLong = "Simple Edge"
pFeatureTypeShort = "Edge"
Case esriGeoDatabase.esriFeatureType.esriFTComplexEdge
pFeatureTypeLong = "Complex Edge"
pFeatureTypeShort = "Edge"
Case Else
'
End Select
'
Set pListItem = pListItems.Add(, , pDatasetFC.Name)
pListItem.SubItems(1) = pFeatureTypeLong
If pFeatureClass.FeatureType = esriFTSimpleJunction Then
pListItem.SmallIcon = 2
Select Case pNetworkClass.NetworkAncillaryRole
Case esriNCARNone
pListItem.SubItems(2) = "None"
Case esriNCARSourceSink
pListItem.SubItems(2) = "Source/Sink"
End Select
Else
pListItem.SmallIcon = 1
pListItem.SubItems(2) = "-"
End If
'---------------------------------------------------------
' Add FeatureClass(s) to FlexGrid - Loop for each Subtype
'---------------------------------------------------------
Set pSubtypes = pFeatureClass
'
If pSubtypes.HasSubtype Then
Set pEnumSubtype = pSubtypes.Subtypes
pSubtypeName = pEnumSubtype.Next(pSubtypeCode)
Do Until pSubtypeName = ""
Me.flexEE.AddItem "" & Chr(9) & _
pFeatureTypeShort & Chr(9) & _
pDatasetFC.Name & Chr(9) & _
pSubtypeName
pSubtypeName = pEnumSubtype.Next(pSubtypeCode)
Loop
Else
Me.flexEE.AddItem "" & Chr(9) & _
pFeatureTypeShort & Chr(9) & _
pDatasetFC.Name & Chr(9) & _
"-"
End If
Next pIndex
'-------------------
' Remove Blank Line
'-------------------
Me.flexEE.RemoveItem 3
'-----------
' Sort Grid
'-----------
Me.flexEE.Col = 0
Me.flexEE.ColSel = 3
Me.flexEE.Sort = 5
'-----------------------------------------
' Add Horizontal Headings (Flex1 & Flex2)
' Add Vertical Headings (Flex2 only)
'-----------------------------------------
For pIndexRow = 0 To Me.flexEE.Rows - 1 Step 1
Select Case Me.flexEE.TextMatrix(pIndexRow, 1)
Case "Junction"
'------------------------------------
' Add Horizontal Heading to MSFLEX 1
'------------------------------------
If Me.flexEE.Cols = 5 Then
If Me.flexEE.TextMatrix(0, 4) <> "" Then
Me.flexEE.Cols = Me.flexEE.Cols + 1
End If
Else
Me.flexEE.Cols = Me.flexEE.Cols + 1
End If
Me.flexEE.Row = 0
Me.flexEE.Col = Me.flexEE.Cols - 1
Me.flexEE.Text = "Junction"
Me.flexEE.CellAlignment = flexAlignCenterCenter
'
Me.flexEE.Row = 1
Me.flexEE.Col = Me.flexEE.Cols - 1
Me.flexEE.Text = Me.flexEE.TextMatrix(pIndexRow, 2)
Me.flexEE.CellAlignment = flexAlignCenterCenter
'
Me.flexEE.Row = 2
Me.flexEE.Col = Me.flexEE.Cols - 1
Me.flexEE.Text = Me.flexEE.TextMatrix(pIndexRow, 3)
Me.flexEE.CellAlignment = flexAlignLeftCenter
'------------------------------------
' Add Horizontal Heading to MSFLEX 2
'------------------------------------
If Me.flexEJ.Cols = 3 Then
If Me.flexEJ.TextMatrix(0, 2) <> "" Then
Me.flexEJ.Cols = Me.flexEJ.Cols + 1
End If
Else
Me.flexEJ.Cols = Me.flexEJ.Cols + 1
End If
Me.flexEJ.Row = 0
Me.flexEJ.Col = Me.flexEJ.Cols - 1
Me.flexEJ.Text = "Junction"
Me.flexEJ.CellAlignment = flexAlignCenterCenter
'
Me.flexEJ.Row = 1
Me.flexEJ.Col = Me.flexEJ.Cols - 1
Me.flexEJ.Text = Me.flexEE.TextMatrix(pIndexRow, 2)
Me.flexEJ.CellAlignment = flexAlignCenterCenter
'
Me.flexEJ.Row = 2
Me.flexEJ.Col = Me.flexEJ.Cols - 1
Me.flexEJ.Text = Me.flexEE.TextMatrix(pIndexRow, 3)
Me.flexEJ.CellAlignment = flexAlignLeftCenter
Case "Edge"
'----------------------------------
' Add Vertical Heading to MSFLEX 2
'----------------------------------
If Me.flexEJ.Rows = 4 Then
If Me.flexEJ.TextMatrix(3, 0) <> "" Then
Me.flexEJ.Rows = Me.flexEJ.Rows + 1
End If
Else
Me.flexEJ.Rows = Me.flexEJ.Rows + 1
End If
Me.flexEJ.Row = Me.flexEJ.Rows - 1
Me.flexEJ.Col = 0
Me.flexEJ.Text = Me.flexEE.TextMatrix(pIndexRow, 2)
Me.flexEJ.CellAlignment = flexAlignLeftCenter
'
Me.flexEJ.Row = Me.flexEJ.Rows - 1
Me.flexEJ.Col = 1
Me.flexEJ.Text = Me.flexEE.TextMatrix(pIndexRow, 3)
Me.flexEJ.CellAlignment = flexAlignLeftCenter
'
Me.flexEJ.RowHeight(Me.flexEJ.Row) = Me.flexEJ.RowHeight(Me.flexEJ.Row) * 2
Case Else
'--------
' Ignore
'--------
End Select
Next pIndexRow
'-------------------------------------------------------------
' Remove "Junction" from Vertical Headings (Left Side)
'-------------------------------------------------------------
For pIndexRow = Me.flexEE.Rows - 1 To 0 Step -1
If Me.flexEE.TextMatrix(pIndexRow, 1) = "Junction" Then
Me.flexEE.RemoveItem (pIndexRow)
End If
Next pIndexRow
'-------------------------------------------------
' Duplicate Edges on Vertical Headings
' - Add Shaded cells and unchecked boxes (FLEX 1)
'-------------------------------------------------
pRowCount = Me.flexEE.Rows - 3
Me.flexEE.Rows = 3 + (pRowCount * pRowCount)
For pIndexRowFrom = 0 To pRowCount - 1 Step 1
For pIndexRowTo = 0 To pRowCount - 1 Step 1
Me.flexEE.Row = (pIndexRowFrom * pRowCount) + pIndexRowTo + 3
'
Me.flexEE.Col = 0
Me.flexEE.Text = Me.flexEE.TextMatrix(pIndexRowFrom + 3, 2)
'
Me.flexEE.Col = 1
Me.flexEE.Text = Me.flexEE.TextMatrix(pIndexRowFrom + 3, 3)
'
Me.flexEE.Col = 2
Me.flexEE.Text = Me.flexEE.TextMatrix(pIndexRowTo + 3, 2)
'
Me.flexEE.Col = 3
Me.flexEE.Text = Me.flexEE.TextMatrix(pIndexRowTo + 3, 3)
'
If pIndexRowFrom > pIndexRowTo Then
For pIndexCol = 4 To Me.flexEE.Cols - 1 Step 1
'-----------------
' Add Shaded Cell
'-----------------
Me.flexEE.Col = pIndexCol
Me.flexEE.CellBackColor = RGB(192, 192, 192)
Next pIndexCol
Else
For pIndexCol = 4 To Me.flexEE.Cols - 1 Step 1
'--------------------
' Add CheckBox (off)
'--------------------
Me.flexEE.Col = pIndexCol
Set Me.flexEE.CellPicture = LoadResPicture("CHECKBOX_OFF", 0)
Me.flexEE.CellFontStrikeThrough = True
Me.flexEE.CellFontBold = False
Me.flexEE.CellPictureAlignment = flexAlignCenterCenter
Next pIndexCol
End If
Next pIndexRowTo
Next pIndexRowFrom
'-------------------------------
' Add Unchecked Boxes to FLEX 2
'-------------------------------
For pIndexRow = 3 To Me.flexEJ.Rows - 1 Step 1
Me.flexEJ.Row = pIndexRow
For pIndexCol = 2 To Me.flexEJ.Cols - 1 Step 1
Me.flexEJ.Col = pIndexCol
Set flexEJ.CellPicture = LoadResPicture("CHECKBOX_OFF", 0)
Me.flexEJ.CellFontStrikeThrough = True
Me.flexEJ.CellFontBold = False
Me.flexEJ.CellPictureAlignment = flexAlignLeftCenter
Me.flexEJ.CellAlignment = flexAlignRightCenter
Me.flexEJ.CellForeColor = RGB(0, 0, 255)
Next pIndexCol
Next pIndexRow
'------------------------------
' Add additional heading cells
'------------------------------
Me.flexEE.TextMatrix(0, 0) = "Edge1"
Me.flexEE.TextMatrix(0, 1) = "Subtype1"
Me.flexEE.TextMatrix(0, 2) = "Edge2"
Me.flexEE.TextMatrix(0, 3) = "Subtype2"
Me.flexEJ.TextMatrix(2, 0) = "Edge"
Me.flexEJ.TextMatrix(2, 1) = "Subtype"
'------------------------------------------------
' Add Edge-Junction-Edge Connectivity CheckBoxes
'------------------------------------------------
Set pEnumRule = mGeometricNetwork.Rules
Set pRule = pEnumRule.Next
'
Do Until pRule Is Nothing
Select Case pRule.Type
Case esriGeoDatabase.esriRuleType.esriRTJunctionConnectivity
'-----------------------------
' Junction Connectivity Rules
'-----------------------------
Set pJunctionConnectivityRule2 = pRule
'---------------------
' Get Rule Properties
'---------------------
Set pFeatureClassEdge = pFeatureClassContainer.ClassByID(pJunctionConnectivityRule2.EdgeClassID)
Set pDatasetEdge = pFeatureClassEdge
Set pSubtypesEdge = pDatasetEdge
If pSubtypesEdge.HasSubtype Then
pSubtypeNameEdge = pSubtypesEdge.SubtypeName(pJunctionConnectivityRule2.EdgeSubtypeCode)
Else
pSubtypeNameEdge = ""
End If
'
Set pFeatureClassJunction = pFeatureClassContainer.ClassByID(pJunctionConnectivityRule2.JunctionClassID)
Set pDatasetJunction = pFeatureClassJunction
Set pSubtypesJunction = pDatasetJunction
If pSubtypesJunction.HasSubtype Then
pSubtypeNameJunction = pSubtypesJunction.SubtypeName(pJunctionConnectivityRule2.JunctionSubtypeCode)
Else
pSubtypeNameJunction = ""
End If
'------------------------------------------
' Find Row (Edge FeatureClass and Subtype)
'------------------------------------------
For pIndexRow = 3 To Me.flexEJ.Rows - 1 Step 1
If Me.flexEJ.TextMatrix(pIndexRow, 0) = pDatasetEdge.Name And _
Me.flexEJ.TextMatrix(pIndexRow, 1) = pSubtypeNameEdge Then
Me.flexEJ.Row = pIndexRow
Exit For
End If
Next pIndexRow
'-------------------------------------------------
' Find Column (Junction FeatureClass and Subtype)
'-------------------------------------------------
For pIndexCol = 2 To Me.flexEJ.Cols - 1 Step 1
If Me.flexEJ.TextMatrix(1, pIndexCol) = pDatasetJunction.Name And _
Me.flexEJ.TextMatrix(2, pIndexCol) = pSubtypeNameJunction Then
Me.flexEJ.Col = pIndexCol
Exit For
End If
Next pIndexCol
'--------------
' Add CheckBox
'--------------
If pJunctionConnectivityRule2.DefaultJunction Then
'--------------------------
' Default Junction/Subtype
'--------------------------
Set Me.flexEJ.CellPicture = LoadResPicture("CHECKBOX_ON_DEFAULT", 0)
Me.flexEJ.CellFontStrikeThrough = False
Me.flexEJ.CellFontBold = True
Else
Set Me.flexEJ.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
Me.flexEJ.CellFontStrikeThrough = False
End If
'-----------------
' Add Cardinality
'-----------------
If pJunctionConnectivityRule2.EdgeMinimumCardinality = -1 Then
Me.flexEJ.Text = "E:" & "0" & ".." & "*"
Else
Me.flexEJ.Text = "E:" & pJunctionConnectivityRule2.EdgeMinimumCardinality & ".." & _
pJunctionConnectivityRule2.EdgeMaximumCardinality
End If
Me.flexEJ.Text = Me.flexEJ.Text & Chr(13)
If pJunctionConnectivityRule2.JunctionMinimumCardinality = -1 Then
Me.flexEJ.Text = Me.flexEJ.Text & "J:" & "0" & ".." & "*"
Else
Me.flexEJ.Text = Me.flexEJ.Text & "J:" & pJunctionConnectivityRule2.JunctionMinimumCardinality & ".." & _
pJunctionConnectivityRule2.JunctionMaximumCardinality
End If
Case esriGeoDatabase.esriRuleType.esriRTEdgeConnectivity
'-------------------------
' Edge Connectivity Rules
'-------------------------
Set pEdgeConnectivityRule = pRule
'---------------------
' Get Rule Properties
'---------------------
Set pFeatureClassEdge1 = pFeatureClassContainer.ClassByID(pEdgeConnectivityRule.FromEdgeClassID)
Set pFeatureClassEdge2 = pFeatureClassContainer.ClassByID(pEdgeConnectivityRule.ToEdgeClassID)
Set pDatasetEdge1 = pFeatureClassEdge1
Set pDatasetEdge2 = pFeatureClassEdge2
Set pSubtypesEdge1 = pFeatureClassEdge1
Set pSubtypesEdge2 = pFeatureClassEdge2
If pSubtypesEdge1.HasSubtype Then
pSubtypeEdgeName1 = pSubtypesEdge1.SubtypeName(pEdgeConnectivityRule.FromEdgeSubtypeCode)
Else
pSubtypeEdgeName1 = "-"
End If
If pSubtypesEdge2.HasSubtype Then
pSubtypeEdgeName2 = pSubtypesEdge2.SubtypeName(pEdgeConnectivityRule.ToEdgeSubtypeCode)
Else
pSubtypeEdgeName2 = "-"
End If
'---------------------------
' Add EDGE -> EDGE CheckBox
'---------------------------
For pIndexRow = 3 To Me.flexEE.Rows - 1 Step 1
If (Me.flexEE.TextMatrix(pIndexRow, 0) = pDatasetEdge1.Name And _
Me.flexEE.TextMatrix(pIndexRow, 1) = pSubtypeEdgeName1 And _
Me.flexEE.TextMatrix(pIndexRow, 2) = pDatasetEdge2.Name And _
Me.flexEE.TextMatrix(pIndexRow, 3) = pSubtypeEdgeName2) Or _
(Me.flexEE.TextMatrix(pIndexRow, 0) = pDatasetEdge2.Name And _
Me.flexEE.TextMatrix(pIndexRow, 1) = pSubtypeEdgeName2 And _
Me.flexEE.TextMatrix(pIndexRow, 2) = pDatasetEdge1.Name And _
Me.flexEE.TextMatrix(pIndexRow, 3) = pSubtypeEdgeName1) Then
Me.flexEE.Row = pIndexRow
Me.flexEE.Col = 4
If Me.flexEE.CellBackColor <> RGB(192, 192, 192) Then
Exit For
End If
End If
Next pIndexRow
'----------------------------------
' Loop Through ALL Valid Junctions
'----------------------------------
For pJunctionCounter = 0 To pEdgeConnectivityRule.JunctionCount - 1 Step 1
Set pFeatureClassJunction = pFeatureClassContainer.ClassByID(pEdgeConnectivityRule.JunctionClassID(pJunctionCounter))
Set pDatasetJunction = pFeatureClassJunction
Set pSubtypesJunction = pFeatureClassJunction
If pSubtypesJunction.HasSubtype Then
pSubtypeJunctionName = pSubtypesJunction.SubtypeName(pEdgeConnectivityRule.JunctionSubtypeCode(pJunctionCounter))
Else
pSubtypeJunctionName = "-"
End If
'
For pIndexCol = 4 To Me.flexEE.Cols - 1 Step 1
If Me.flexEE.TextMatrix(1, pIndexCol) = pDatasetJunction.Name And _
Me.flexEE.TextMatrix(2, pIndexCol) = pSubtypeJunctionName Then
Me.flexEE.Col = pIndexCol
Exit For
End If
Next pIndexCol
'
If pEdgeConnectivityRule.JunctionClassID(pJunctionCounter) = pEdgeConnectivityRule.DefaultJunctionClassID And _
pEdgeConnectivityRule.JunctionSubtypeCode(pJunctionCounter) = pEdgeConnectivityRule.DefaultJunctionSubtypeCode Then
'--------------------------
' Default Junction/Subtype
'--------------------------
Set Me.flexEE.CellPicture = LoadResPicture("CHECKBOX_ON_DEFAULT", 0)
Me.flexEE.CellFontBold = True
Me.flexEE.CellFontStrikeThrough = False
Else
Set Me.flexEE.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
Me.flexEE.CellFontStrikeThrough = False
End If
Next pJunctionCounter
End Select
'
Set pRule = pEnumRule.Next
Loop
'-----------------
' Enable Controls
'-----------------
Call EnableFrame(Me.fmeGeometricNetworkName, True)
Call EnableFrame(Me.fmeNetworkClass, True)
Call EnableFrame(Me.fmeEE, True)
Call EnableFrame(Me.fmeEJ, True)
'-------------------------
' Disable the Load Button
'-------------------------
Me.cmdLoad.Enabled = False
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cmdLoad_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrorHandler
'
Set mApplication = Nothing
Set mGeometricNetwork = Nothing
'
Exit Sub
ErrorHandler:
Call HandleError(True, "Form_Unload " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub flexEE_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo ErrorHandler
'
Call KeyPressGridEvent(Me.flexEE, KeyCode, Shift)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "flexEE_KeyDown " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub flexEJ_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call KeyPressGridEvent(Me.flexEJ, KeyCode, Shift)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "flexEJ_KeyDown " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub KeyPressGridEvent(ByRef pMSHFlexGrid As MSHierarchicalFlexGridLib.MSHFlexGrid, _
ByVal pKeyCode As Integer, ByVal pShift As Integer)
On Error GoTo ErrorHandler
'
Dim pStartColumn As Long
Dim pStartRow As Long
Dim pIndexCol As Long
Dim pIndexRow As Long
Dim pIndexColClick As Long
Dim pIndexRowClick As Long
'--------------------------
' Turn Off FlexGrid Redraw
'--------------------------
Me.flexEE.Redraw = False
'
pIndexColClick = pMSHFlexGrid.Col
pIndexRowClick = pMSHFlexGrid.Row
'
Select Case Me.TabStrip1.SelectedItem.Index
Case 2
pStartColumn = 4
pStartRow = 3
Case 3
pStartColumn = 2
pStartRow = 3
End Select
'
If pMSHFlexGrid.CellBackColor = RGB(192, 192, 192) Then
'-------------------------
' This is Greyed-out Box!
'-------------------------
Exit Sub
End If
'
Select Case pKeyCode
Case vbKeyD, vbKeyD + 32
'--------------------------------------
' If already DEFAULT then make ON only
'--------------------------------------
If pMSHFlexGrid.CellFontBold Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
pMSHFlexGrid.CellFontBold = False
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
Else
'--------------------------------------------------------------------
' If OFF/ON then make DEFAULT - First uncheck all other boxes in row
'--------------------------------------------------------------------
If pMSHFlexGrid.CellFontStrikeThrough Then
Call ExplicitlyAddEJRule
End If
For pIndexCol = pStartColumn To pMSHFlexGrid.Cols - 1 Step 1
pMSHFlexGrid.Col = pIndexCol
If pIndexCol = pIndexColClick Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON_DEFAULT", 0)
pMSHFlexGrid.CellFontBold = True
pMSHFlexGrid.CellFontStrikeThrough = False
Else
If pMSHFlexGrid.CellFontBold Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = False
End If
End If
Next pIndexCol
End If
'
Me.cmdApply.Enabled = True
Case vbKeyQ, vbKeyQ + 32
Select Case pShift
Case 0
If Me.flexEE.CellBackColor = RGB(192, 192, 192) Then
'-------------------------
' This is Greyed-out Box!
'-------------------------
Else
'------------------
' Check or Uncheck
'------------------
If pMSHFlexGrid.CellFontStrikeThrough Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = False
'-----------------------------------
' Assign Cardinality if not present
'-----------------------------------
If Me.TabStrip1.SelectedItem.Index = 3 Then
If pMSHFlexGrid.Text = "" Then
pMSHFlexGrid.Text = "E:" & "0" & ".." & "*" & Chr(13) & "J:" & "0" & ".." & "*"
End If
End If
'------------------------------
' Explicitly Add Junction Rule
'------------------------------
Call ExplicitlyAddEJRule
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
Else
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_OFF", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = True
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
End If
End If
Case vbShiftMask
'--------------------------------
' CONTROL - Q: Check/Uncheck Row
'--------------------------------
If pMSHFlexGrid.CellFontStrikeThrough Then
For pIndexRow = pStartRow To pMSHFlexGrid.Rows - 1 Step 1
pMSHFlexGrid.Row = pIndexRow
If pMSHFlexGrid.CellBackColor <> RGB(192, 192, 192) Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = False
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
'------------------------------
' Explicitly Add Junction Rule
'------------------------------
Call ExplicitlyAddEJRule
End If
Next pIndexRow
Else
For pIndexRow = pStartRow To pMSHFlexGrid.Rows - 1 Step 1
pMSHFlexGrid.Row = pIndexRow
If pMSHFlexGrid.CellBackColor <> RGB(192, 192, 192) Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_OFF", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = True
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
End If
Next pIndexRow
End If
Case vbCtrlMask
'--------------------------------
' CONTROL - Q: Check/Uncheck Row
'--------------------------------
If pMSHFlexGrid.CellFontStrikeThrough Then
For pIndexCol = pStartColumn To pMSHFlexGrid.Cols - 1 Step 1
pMSHFlexGrid.Col = pIndexCol
If pMSHFlexGrid.CellFontStrikeThrough Then
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = False
'------------------------------
' Explicitly Add Junction Rule
'------------------------------
Call ExplicitlyAddEJRule
Else
'------------------------
' Already Checked - Skip
'------------------------
End If
Next pIndexCol
'-----------------------------------
' Checked Row For Default Junctions
'-----------------------------------
Call CheckDefaultJunction
Else
For pIndexCol = pStartColumn To pMSHFlexGrid.Cols - 1 Step 1
pMSHFlexGrid.Col = pIndexCol
Set pMSHFlexGrid.CellPicture = LoadResPicture("CHECKBOX_OFF", 0)
pMSHFlexGrid.CellFontBold = False
pMSHFlexGrid.CellFontStrikeThrough = True
Next pIndexCol
End If
End Select
'
Me.cmdApply.Enabled = True
Case vbKeyLeft, vbKeyRight, vbKeyUp, vbKeyDown
If Me.TabStrip1.SelectedItem.Index = 3 Then
mMouseClick = True
'
If Me.chkEJPersist.Value = vbChecked Then
'------------------
' Persist Existing
'------------------
Call UpdateCellCardinality
Me.cmdApply.Enabled = True
Else
'-------------
' Non-Persist
'-------------
Call UpdateCardinalityEditor
End If
'
mMouseClick = False
End If
End Select
'-------------------------
' Turn On FlexGrid Redraw
'-------------------------
Me.flexEE.Redraw = True
'-------------------------------
' Reset the selected Row/Column
'-------------------------------
pMSHFlexGrid.Col = pIndexColClick
pMSHFlexGrid.Row = pIndexRowClick
'
Exit Sub
ErrorHandler:
Call HandleError(False, "KeyPressGridEvent " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub DisplayRuleDescriptionEE()
On Error GoTo ErrorHandler
'
Dim pEdgeFrom As String
Dim pEdgeSubtypeFrom As String
Dim pEdgeTo As String
Dim pEdgeSubtypeTo As String
Dim pJunction As String
Dim pJunctionSubtype As String
'
Dim pMessage As String
'
If Me.flexEE.CellBackColor = RGB(192, 192, 192) Then
Me.flexEE.ToolTipText = ""
Exit Sub
End If
'
pEdgeFrom = Me.flexEE.TextMatrix(Me.flexEE.Row, 0)
pEdgeSubtypeFrom = Me.flexEE.TextMatrix(Me.flexEE.Row, 1)
pEdgeTo = Me.flexEE.TextMatrix(Me.flexEE.Row, 2)
pEdgeSubtypeTo = Me.flexEE.TextMatrix(Me.flexEE.Row, 3)
pJunction = Me.flexEE.TextMatrix(1, Me.flexEE.Col)
pJunctionSubtype = Me.flexEE.TextMatrix(2, Me.flexEE.Col)
'
If Me.flexEE.CellFontStrikeThrough Then
'-------------
' Not checked
'-------------
pMessage = "Edges " & _
Chr(34) & pEdgeFrom & "/" & pEdgeSubtypeFrom & Chr(34) & " and " & _
Chr(34) & pEdgeTo & "/" & pEdgeSubtypeTo & Chr(34) & " can NOT connect via Junction " & _
Chr(34) & pJunction & "/" & pJunctionSubtype & Chr(34)
Else
'---------
' Checked
'---------
pMessage = "Edges " & _
Chr(34) & pEdgeFrom & "/" & pEdgeSubtypeFrom & Chr(34) & " and " & _
Chr(34) & pEdgeTo & "/" & pEdgeSubtypeTo & Chr(34) & " CAN connect via Junction " & _
Chr(34) & pJunction & "/" & pJunctionSubtype & Chr(34)
If Me.flexEE.CellFontBold Then
pMessage = pMessage & " (Default Junction)"
End If
End If
'
Me.flexEE.ToolTipText = pMessage
'
Exit Sub
ErrorHandler:
Call HandleError(False, "DisplayRuleDescriptionEE " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub flexEJ_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
mMouseClick = True
'
If Me.chkEJPersist.Value = vbChecked Then
'------------------
' Persist Existing
'------------------
Call UpdateCellCardinality
Else
'-------------
' Non-Persist
'-------------
Call UpdateCardinalityEditor
End If
'
mMouseClick = False
'
Exit Sub
ErrorHandler:
Call HandleError(True, "flexEJ_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub UpdateCardinalityEditor()
On Error GoTo ErrorHandler
'
Dim pCardinality As String
Dim pEmin As String
Dim pEmax As String
Dim pJmin As String
Dim pJmax As String
'
pCardinality = Me.flexEJ.TextMatrix(Me.flexEJ.Row, Me.flexEJ.Col)
'
If pCardinality = "" Then
Me.cboEmin.Text = "-"
Me.cboEmax.Text = "-"
Me.cboJmin.Text = "-"
Me.cboJmax.Text = "-"
Else
pEmin = CStr(Mid(pCardinality, 3, 1))
pEmax = CStr(Mid(pCardinality, 6, 1))
pJmin = CStr(Mid(pCardinality, 10, 1))
pJmax = CStr(Mid(pCardinality, 13, 1))
'
If pEmax = "*" Then
Me.cboEmin.Text = "-"
Me.cboEmax.Text = "-"
Else
Me.cboEmin.Text = pEmin
Me.cboEmax.Text = pEmax
End If
If pJmax = "*" Then
Me.cboJmin.Text = "-"
Me.cboJmax.Text = "-"
Else
Me.cboJmin.Text = pJmin
Me.cboJmax.Text = pJmax
End If
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "UpdateCardinalityEditor " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub sldEEWidth_Change()
On Error GoTo ErrorHandler
'
Dim pIndexCol As Long
'
If Not Me.Visible Then
Exit Sub
End If
'
For pIndexCol = 4 To Me.flexEE.Cols - 1 Step 1
Me.flexEE.ColWidth(pIndexCol) = Me.sldEEWidth.Value
Next pIndexCol
'
Exit Sub
ErrorHandler:
Call HandleError(True, "sldEEWidth_Change " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub sldEJWidth_Change()
On Error GoTo ErrorHandler
'
Dim pIndexCol As Long
'
If Not Me.Visible Then
Exit Sub
End If
'
For pIndexCol = 2 To Me.flexEJ.Cols - 1 Step 1
Me.flexEJ.ColWidth(pIndexCol) = Me.sldEJWidth.Value
Next pIndexCol
'
Exit Sub
ErrorHandler:
Call HandleError(True, "sldEJWidth_Change " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub TabStrip1_Click()
On Error GoTo ErrorHandler
'
Call ClickTabStrip
'
Exit Sub
ErrorHandler:
Call HandleError(True, "TabStrip1_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ClickTabStrip()
On Error GoTo ErrorHandler
'
Select Case Me.TabStrip1.SelectedItem.Index
Case 1
Me.fmeGeometricNetworkName.Visible = True
Me.fmeNetworkClass.Visible = True
Me.fmeEE.Visible = False
Me.fmeEJ.Visible = False
Case 2
Me.fmeGeometricNetworkName.Visible = False
Me.fmeNetworkClass.Visible = False
Me.fmeEE.Visible = True
Me.fmeEJ.Visible = False
Case 3
Me.fmeGeometricNetworkName.Visible = False
Me.fmeNetworkClass.Visible = False
Me.fmeEE.Visible = False
Me.fmeEJ.Visible = True
End Select
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ClickTabStrip " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub chkEEShowEdgeSubtype_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
If Me.chkEEShowEdgeSubtype.Value = vbChecked Then
Me.flexEE.ColWidth(1) = Me.flexEE.ColWidth(0)
Me.flexEE.ColWidth(3) = Me.flexEE.ColWidth(0)
Else
Me.flexEE.ColWidth(1) = 0
Me.flexEE.ColWidth(3) = 0
End If
'
Exit Sub
ErrorHandler:
Call HandleError(True, "chkEEShowEdgeSubtype_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub chkEEShowJunctionSubtype_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
If Me.chkEEShowJunctionSubtype.Value = vbChecked Then
Me.flexEE.RowHeight(2) = Me.flexEE.RowHeight(0)
Else
Me.flexEE.RowHeight(2) = 0
End If
'
Exit Sub
ErrorHandler:
Call HandleError(True, "chkEEShowJunctionSubtype_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub chkEJShowEdgeSubtype_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
If Me.chkEJShowEdgeSubtype.Value = vbChecked Then
Me.flexEJ.ColWidth(1) = Me.flexEJ.ColWidth(0)
Else
Me.flexEJ.ColWidth(1) = 0
End If
'
Exit Sub
ErrorHandler:
Call HandleError(True, "chkEJShowEdgeSubtype_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub chkEJShowJunctionSubtype_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
If Me.chkEJShowJunctionSubtype.Value = vbChecked Then
Me.flexEJ.RowHeight(2) = Me.flexEJ.RowHeight(0)
Else
Me.flexEJ.RowHeight(2) = 0
End If
'
Exit Sub
ErrorHandler:
Call HandleError(True, "chkEJShowJunctionSubtype_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboEmin_Change()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickLeftComboEvent(Me.cboEmin, Me.cboEmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboEmin_Change " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboEmin_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickLeftComboEvent(Me.cboEmin, Me.cboEmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboEmin_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboEmax_Change()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickRightComboEvent(Me.cboEmin, Me.cboEmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboEmax_Change " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboEmax_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickRightComboEvent(Me.cboEmin, Me.cboEmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboEmax_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboJmin_Change()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickLeftComboEvent(Me.cboJmin, Me.cboJmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboJmin_Change " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboJmin_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickLeftComboEvent(Me.cboJmin, Me.cboJmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboJmin_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboJmax_Change()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickRightComboEvent(Me.cboJmin, Me.cboJmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboJmax_Change " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub cboJmax_Click()
On Error GoTo ErrorHandler
'
If Not Me.Visible Then
Exit Sub
End If
'
Call ClickRightComboEvent(Me.cboJmin, Me.cboJmax)
'
Exit Sub
ErrorHandler:
Call HandleError(True, "cboJmax_Click " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ClickLeftComboEvent(ByRef pComboLeft As ComboBox, ByRef pComboRight As ComboBox)
On Error GoTo ErrorHandler
'
If mMouseClick Then
Exit Sub
End If
'
Select Case pComboLeft.Text
Case "-"
pComboRight.Text = "-"
Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
If IsNumeric(pComboRight.Text) Then
If CLng(pComboRight.Text) < CLng(pComboLeft.Text) Then
pComboRight.Text = pComboLeft.Text
End If
Else
pComboRight.Text = pComboLeft.Text
End If
Case Else
pComboLeft.Text = "-"
pComboRight.Text = "-"
End Select
'
Call UpdateCellCardinality
'
Me.cmdApply.Enabled = True
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ClickLeftComboEvent " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ClickRightComboEvent(ByRef pComboLeft As ComboBox, ByRef pComboRight As ComboBox)
On Error GoTo ErrorHandler
'
If mMouseClick Then
Exit Sub
End If
'
Select Case pComboRight.Text
Case "-"
pComboLeft.Text = "-"
Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
If IsNumeric(pComboLeft.Text) Then
If CLng(pComboRight.Text) < CLng(pComboLeft.Text) Then
pComboLeft.Text = pComboRight.Text
End If
Else
pComboLeft.Text = 0
End If
Case Else
pComboLeft.Text = "-"
pComboRight.Text = "-"
End Select
'
Call UpdateCellCardinality
'
Me.cmdApply.Enabled = True
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ClickRightComboEvent " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub UpdateCellCardinality()
On Error GoTo ErrorHandler
'
If Me.cboEmin.Text = "-" Then
Me.flexEJ.Text = "E:" & "0" & ".." & "*"
Else
Me.flexEJ.Text = "E:" & Me.cboEmin.Text & ".." & Me.cboEmax.Text
End If
Me.flexEJ.Text = Me.flexEJ.Text & Chr(13)
If Me.cboJmin.Text = "-" Then
Me.flexEJ.Text = Me.flexEJ.Text & "J:" & "0" & ".." & "*"
Else
Me.flexEJ.Text = Me.flexEJ.Text & "J:" & Me.cboJmin.Text & ".." & Me.cboJmax.Text
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "UpdateCellCardinality " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub ExplicitlyAddEJRule()
On Error GoTo ErrorHandler
'
If Me.TabStrip1.SelectedItem.Index <> 2 Then
Exit Sub
End If
'
If Me.chkEEAutoCreateEJRule.Value <> vbChecked Then
Exit Sub
End If
'
Dim pEdge1 As String
Dim pEdgeSubtype1 As String
Dim pEdge2 As String
Dim pEdgeSubtype2 As String
Dim pJunction As String
Dim pJunctionSubtype As String
'
Dim pIndexRow As Long
Dim pIndexCol As Long
Dim pMakeDefault As Boolean
'
pEdge1 = Me.flexEE.TextMatrix(Me.flexEE.Row, 0)
pEdgeSubtype1 = Me.flexEE.TextMatrix(Me.flexEE.Row, 1)
pEdge2 = Me.flexEE.TextMatrix(Me.flexEE.Row, 2)
pEdgeSubtype2 = Me.flexEE.TextMatrix(Me.flexEE.Row, 3)
'
pJunction = Me.flexEE.TextMatrix(1, Me.flexEE.Col)
pJunctionSubtype = Me.flexEE.TextMatrix(2, Me.flexEE.Col)
'-------------
' Find Column
'-------------
For pIndexCol = 2 To Me.flexEJ.Cols - 1 Step 1
If Me.flexEJ.TextMatrix(1, pIndexCol) = pJunction And _
Me.flexEJ.TextMatrix(2, pIndexCol) = pJunctionSubtype Then
'------------
' Set Column
'------------
Me.flexEJ.Col = pIndexCol
Exit For
End If
Next pIndexCol
'----------
' Find Row
'----------
For pIndexRow = 3 To Me.flexEJ.Rows - 1 Step 1
If (Me.flexEJ.TextMatrix(pIndexRow, 0) = pEdge1 And _
Me.flexEJ.TextMatrix(pIndexRow, 1) = pEdgeSubtype1) Or _
(Me.flexEJ.TextMatrix(pIndexRow, 0) = pEdge2 And _
Me.flexEJ.TextMatrix(pIndexRow, 1) = pEdgeSubtype2) Then
'---------
' Set Row
'---------
Me.flexEJ.Row = pIndexRow
'-------------------------
' Skip if already checked
'-------------------------
If Me.flexEJ.CellFontStrikeThrough Then
'--------------
' Add CheckBox
'--------------
Set Me.flexEJ.CellPicture = LoadResPicture("CHECKBOX_ON", 0)
Me.flexEJ.CellFontStrikeThrough = False
'-----------------
' Add Cardinality
'-----------------
Me.flexEJ.Text = "E:" & "0" & ".." & "*" & Chr(13) & "J:" & "0" & ".." & "*"
End If
End If
Next pIndexRow
'
Exit Sub
ErrorHandler:
Call HandleError(False, "ExplicitlyAddEJRule " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub CheckDefaultJunction()
On Error GoTo ErrorHandler
'
If Me.TabStrip1.SelectedItem.Index <> 2 Then
Exit Sub
End If
'
Const pStartColumn As Long = 4
'
Dim pIndexCol As Long
Dim pIndexColClick As Long
'
Dim pFirstChecked As Long
Dim pTotalChecked As Long
Dim pTotalDefault As Long
Dim pHaveDefault As Boolean
'
pIndexColClick = Me.flexEE.Col
pFirstChecked = 0
pHaveDefault = False
'
For pIndexCol = pStartColumn To Me.flexEE.Cols - 1 Step 1
Me.flexEE.Col = pIndexCol
'
If Not Me.flexEE.CellFontStrikeThrough Then
'-----------------
' Cell is Checked
'-----------------
If pFirstChecked = 0 Then
'---------------------
' Get Colomn of First
'---------------------
pFirstChecked = pIndexCol
End If
'------------------
' Check if Default
'------------------
If Me.flexEE.CellFontBold Then
'----------------------------
' Cell is Default - Exit For
'----------------------------
pHaveDefault = True
Exit For
End If
End If
Next pIndexCol
'
If pHaveDefault Then
'-------------------------------
' Already Have Default Junction
'-------------------------------
Else
If pFirstChecked <> 0 Then
Me.flexEE.Col = pFirstChecked
Set Me.flexEE.CellPicture = LoadResPicture("CHECKBOX_ON_DEFAULT", 0)
Me.flexEE.CellFontBold = True
End If
End If
'-------------------------
' Restore Selected Column
'-------------------------
Me.flexEE.Col = pIndexColClick
'
Exit Sub
ErrorHandler:
Call HandleError(False, "CheckDefaultJunction " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Sub UpdateStatusBar(ByRef pMessage As String)
On Error GoTo ErrorHandler
'
Me.StatusBar1.SimpleText = pMessage
DoEvents
'
Exit Sub
ErrorHandler:
Call HandleError(False, "UpdateStatusBar " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub