yes
al
'*********************************************************************
'*********************************************************************
'
' Custom properties
'
'*********************************************************************
'*********************************************************************
Public Function AddCustomPropertyToShape(vsoShape As Visio.Shape, _
strLocalRowName As String, _
strRowNameU As String, _
strLabelName As String, _
Optional vsoPropType As VisCellVals, _
Optional strFormat As String, _
Optional strPrompt As String, _
Optional blnAskOnDrop As Boolean, _
Optional blnHidden As Boolean, _
Optional strSortKey As String) As Boolean
' AddCustomProperty
'
' Abstract - This function creates a custom property
' for the shape that is passed in as a parameter.
'
' Parameters
' vsoShape Reference to the Shape object
'
' strLocalRowName Specifies the local name for the row.
' This name will appear in the Custom
' properties dialog for users running
' in developer mode.
'
' strRowNameU Specifies the universal name (NameU)
' for the Custom Property row to be
' created.
'
' strLabelName Specifies the label for the Custom
' Property.
'
' vsoPropType Specifies the type of the value of
' the Custom Property. Not all VisCellVals
' constants are valid for this parameter.
' Only constants that start with visPropType make
' sense in this context.
'
' strFormat Specifies the format of the
' Custom Property.
'
' strPrompt Specifies the prompt for the
' Custom Property.
'
' blnAskOnDrop Specifies the value of the
' Ask On Drop check box of the
' Custom Property.
'
' blnHidden Specifies the value of the
' Hidden check box of the Custom Property.
'
' strSortKey Specifies the value of the
' Sort key of the Custom Property.
'
' Return Value True if successful, False otherwise.
'
Dim vsoCell As Visio.Cell
Dim intRowIndex As Integer
Dim strValue As String
On Error GoTo AddCustomProperty_Err
If vsoShape.SectionExists(visSectionProp, False) = False Then
vsoShape.AddSection (visSectionProp)
End If
' Add a named Custom Property row. In addition to
' adding a row with the local name (strLocalRowNname),
' this call will usually set the universal name of
' the new row to strLocalRowName as well.
' However, the universal row name will not be set
' if this shape already has a custom property row
' with the universal name (NameU) equal to strLocalRowName.
intRowIndex = vsoShape.AddNamedRow(visSectionProp, _
strLocalRowName, VisRowIndices.visRowProp)
' The columns of the properties that this functions
' sets are fixed, and can be accessed directly using
' the CellsSRC method and column index.
' Column 1: Prompt
' Get the Cell object.
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsPrompt)
SetCellValueToString vsoCell, strPrompt
' Any cell in the row can be used to set the
' universal row name. Only set the name if
' strRowNameU differs from the local name and
' is not blank.
If (strLocalRowName <> strRowNameU And _
Len(strRowNameU) > 0) Then
vsoCell.rowNameU = strRowNameU
End If
' Column 2: Label
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsLabel)
SetCellValueToString vsoCell, strLabelName
' Column 3: Format
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsFormat)
SetCellValueToString vsoCell, strFormat
' Column 4: Sort Key
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsSortKey)
SetCellValueToString vsoCell, strSortKey
' Column 5: Type
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsType)
strValue = CStr(vsoPropType)
SetCellValueToString vsoCell, strValue
' Column 6: Hidden
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsInvis)
strValue = CStr(blnHidden)
SetCellValueToString vsoCell, strValue
' Column 7: Ask to drop
Set vsoCell = vsoShape.CellsSRC(visSectionProp, _
visRowProp + intRowIndex, visCustPropsAsk)
strValue = CStr(blnAskOnDrop)
SetCellValueToString vsoCell, strValue
AddCustomPropertyToShape = True
Exit Function
AddCustomProperty_Err:
Debug.Print Err.Description
End Function
)