ok, you do understand that what you're asking for requires custom coding
that is not in the product.
The challenge here is that there are two parts to getting the 'shelf'
number. The first is that the shelves in the rack add-in are not named, so a
piece of code would have to be written to put a more friendly name into the
connections section. The second part is to have a mouse handler that would
figure out where you are clicking and if it is a rack then figure out where
you are in the rack to give you a shelf 'name'.
the first part renaming the shelves might use something like this.
'
' go through a rack and add connection point names so that
' we can address at a shelf level
'
Public Sub RenameRackShelfRows(ByVal visShape As Visio.Shape)
Dim visSection As Visio.Section
Dim visRow As Visio.Row
Dim strShelfName As String
Set visSection = visShape.Section(visSectionConnectionPts)
Dim intX As Integer
Dim intY As Integer
Dim intShelf As Integer
Dim rowName As String
rowName = ""
' connections start at zero
For intX = 0 To visSection.Count - 1
Set visRow = visSection.Row(intX)
strShelfName = "shelf_"
intY = (intX + 1) Mod 2 ' are we odd or even
If intY = 0 Then
intShelf = ((intX + 1) / 2)
strShelfName = strShelfName & "right_"
Else
intShelf = (intX / 2) + 1
strShelfName = strShelfName & "left_"
End If
visRow.NameU = strShelfName & CStr(intShelf)
visRow.Name = strShelfName & CStr(intShelf)
Next intX
End Sub
The second part might take advantage of some material in the visio sdk in
capturing mouse events and identifiying which shape was being pointed at.
'
' modified from the sdk
'
Private Sub vsoApplication_MouseUp _
(ByVal lngButton As Long, _
ByVal lngKeyButtonState As Long, _
ByVal dblX As Double, _
ByVal dblY As Double, _
blnCancelDefault As Boolean)
'
Const TOLERANCE As Double = 0.0001
Dim vsoClickedShapes As Visio.Selection
Dim vsoShape As Visio.Shape
Dim lngNextShape As Long
Dim strMessage As String
Dim strMasterName As String
Dim intName As Integer
On Error GoTo vsoApplication_MouseUp_Err
Set vsoWindow = vsoApplication.ActiveWindow
' Check if the left mouse Button caused this event to occur.
If lngButton = Visio.VisKeyButtonFlags.visMouseLeft Then
' Get the list of shapes at the click location.
Set vsoClickedShapes = getMouseClickShapes( _
vsoWindow.PageAsObj, dblX, dblY, TOLERANCE)
' Check if any shapes were found.
' if only one is found then check to see if it is a rack
If (Not vsoClickedShapes Is Nothing) Then
If (vsoClickedShapes.Count = 1) Then
Set vsoShape = vsoClickedShapes.Item(1)
strMasterName = vsoShape.Master.NameU
intName = InStr(1, LCase(strMasterName), "rack")
If 0 < intName Then
strMessage = getShelf(vsoShape, dblX, dblY)
Else
' no rack in name get out
Exit Sub
End If
If (vsoApplication.AlertResponse = 0) Then
MsgBox strMessage
End If
End If
End If
End If
Exit Sub
vsoApplication_MouseUp_Err:
Debug.Print Err.Description
End Sub
'
' this is from the sdk
'
Private Function getMouseClickShapes _
(ByVal vsoClickedPage As Visio.Page, _
ByVal dblClickedLocationX As Double, _
ByVal dblClickedLocationY As Double, _
ByVal dblTolerance As Double) _
As Visio.Selection
Dim vsoClickedShapes As Visio.Selection
On Error GoTo GetMouseClickShapes_Err
' Use the SpatialSearch function of the page to get the list
' of shapes at the location.
Set vsoClickedShapes = vsoClickedPage.SpatialSearch( _
dblClickedLocationX, dblClickedLocationY, _
Visio.VisSpatialRelationCodes.visSpatialContainedIn, _
dblTolerance, Visio.VisSpatialRelationFlags.visSpatialFrontToBack)
Set getMouseClickShapes = vsoClickedShapes
Exit Function
GetMouseClickShapes_Err:
Debug.Print Err.Description
End Function
The final part would be to add investigate the shape based on the mouse
click to find the shelf based on the connection points
' assumes the connections in the rack have been renamed
' connection formula for y
'=User.BaseHeight+IF(Prop.UCount>1,1,Prop.UCount)*User.OneUHeight
' so function should be asware of baseheight and oneuheight from
' the shape
Private Function getShelf _
(ByVal vsoShape As Visio.Shape, _
ByVal dblMouseX As Double, _
ByVal dblMouseY As Double) As String
Dim vsoCell As Visio.Cell
Dim vsoSection As Visio.Section
Dim strMasterName As String
Dim strPinX As String
Dim dblPinX As Double
Dim strPinY As String
Dim dblPinY As Double
Dim strBase As String
Dim dblBase As Double
Dim strUHeight As String
Dim dblUHeight As Double
Dim strMouseX As String
Dim strMouseY As String
Dim dblDisplace As Double
Dim strShelf As String
strShelf = "Not Found"
Dim intConnCt As Integer
Dim strConnCt As String
Dim intX As Integer
Dim strMessage As String
' for debug
strMasterName = vsoShape.Master.NameU
strMessage = Left(strMasterName, 4)
strMouseX = " mouseX " & CStr(dblMouseX) & vbCrLf
strMouseY = " mouseY " & CStr(dblMouseY) & vbCrLf
'get the page horizontal position
If vsoShape.CellExists("pinX", False) Then
Set vsoCell = vsoShape.Cells("pinx")
' the vertical middle
strPinX = " pinX " & CStr(vsoCell.ResultIU) & vbCrLf
dblPinX = vsoCell.ResultIU
End If
' get the page vertical position
If vsoShape.CellExists("pinY", False) Then
Set vsoCell = vsoShape.Cells("pinY")
' the bottom
strPinY = " pinY " & CStr(vsoCell.ResultIU) & vbCrLf
dblPinY = vsoCell.ResultIU
End If
' get the rack displacement
If vsoShape.CellExists("user.BaseHeight", False) Then
Set vsoCell = vsoShape.Cells("user.baseheight")
strBase = " Base " & CStr(vsoCell.ResultIU) & vbCrLf
dblBase = vsoCell.ResultIU
Else
strMessage = "Not a Rack addin shape"
End If
dblDisplace = dblMouseY - (dblPinY + dblBase)
' get the unit height to use as a range for testing
If vsoShape.CellExists("User.OneUHeight", False) Then
Set vsoCell = vsoShape.Cells("User.Oneuheight")
' the bottom
strUHeight = " OneUHeight " & CStr(vsoCell.ResultIU) & vbCrLf
dblUHeight = vsoCell.ResultIU
End If
If vsoShape.SectionExists(visSectionConnectionPts, False) = True
Then
Set vsoSection = vsoShape.Section(visSectionConnectionPts)
intConnCt = vsoSection.Count
strConnCt = " conns " & CStr(intConnCt) & vbCrLf
For intX = 0 To intConnCt - 1
' get the y for the connection point
Set vsoCell = vsoShape.CellsSRC _
(visSectionConnectionPts, intX, visY)
If dblDisplace <= vsoCell.ResultIU _
And dblDisplace < vsoCell.ResultIU + dblUHeight Then
strShelf = vsoSection.Row(intX).NameU
strShelf = Right(strShelf, 3)
strShelf = Replace(strShelf, "t", "")
strShelf = Replace(strShelf, "_", "")
strShelf = "shelf " & strShelf
Exit For
End If
Next intX
End If
' our debug message
strMessage = strMessage & vbCrLf _
& strPinX & strPinY _
& strBase & strUHeight _
& strMouseX & strMouseY _
& strConnCt
' return the shelf number
getShelf = strShelf
End Function
hope this helps to get you started on what you want to do,
al
