Addition of user property to an existing shape

[william slaney]

I have shamelessly borrowed this code (thank you Visio Guy) and wrapped it in a callable sub.  When I first ran this it produced a system error #NAME although the code compiles without error.   The second time I tried it (trying to pin point the error) it came back another error "Delivery name already exits, choose another"  Examining the shape sheet reports a partially completed property but it does not meet .CellExistsU().

Here's the code:

Private Sub AddShapeProp(ByRef oShape As Visio.Shape, PropName As String, PropPrompt As String, PropValue As String)
    'Adds the user property to existing shape

    Dim intPropRow As Integer
   
    intPropRow = oShape.AddRow(visSectionProp, visRowLast, visTagDefault)
   
    With oShape
        .Section(visSectionProp).Row(intPropRow).NameU = PropName
        .CellsSRC(visSectionProp, intPropRow, visCustPropsLabel).FormulaU = QuoteIt(PropName)
        .CellsSRC(visSectionProp, intPropRow, visCustPropsType).FormulaU = "0"
        .CellsSRC(visSectionProp, intPropRow, visCustPropsFormat).FormulaU = ""
        .CellsSRC(visSectionProp, intPropRow, visCustPropsLangID).FormulaU = "1043"
        .CellsSRC(visSectionProp, intPropRow, visCustPropsCalendar).FormulaU = ""
        .CellsSRC(visSectionProp, intPropRow, visCustPropsPrompt).FormulaU = PropPrompt
        .CellsSRC(visSectionProp, intPropRow, visCustPropsValue).FormulaU = PropValue
        .CellsSRC(visSectionProp, intPropRow, visCustPropsSortKey).FormulaU = ""
    End With
   
End Sub

Don't seem to be able to paste a snip from the shape sheet But I can email it if needed, also the function Quoteit() just appends fore and aft quotes  to the value

[Surrogate]

but it does not meet .CellExistsU().

Which flag do you use as fExistsLocally in CellExistsU ?

[Yacine]

To add to surrogate.
You can move the cellexistsU into the subroutine, make the sub a function and handle the error if the name exists.
Return an object if everything is fine (eg the row) or nothing if an error occured.

[william slaney]

Hi Yacine,  and thank you

I was using this:

       Private Const msUSERPROPNAME As String = "Delivery" 

       If oShape.CellExistsU("Prop." & msUSERPROPNAME, visExistsAnywhere) = 0 Then
              Call AddShapeProp(oShape, msUSERPROPNAME, "Deliverable", "")
       End If
However since it should only exist locally, would I better off using visExistsLocally

[Yacine]

However since it should only exist locally, would I better off using visExistsLocally

I wouldn't, visExistsEveryWhere covers all the cases.

[william slaney]

Have taken you advice  and converted the sub to a function which returns a null string if without problem or the error string generated otherwise'

Private Function AddShapeProp(ByRef oShape As Visio.Shape, PropName As String, PropPrompt As String, PropValue As String) As String
    'Adds the user property to existing shape and reurns a null string if successful or and error message otherwise

    Dim intPropRow As Integer
   
    On Error GoTo ErrTrap
   
    AddShapeProp = ""
    intPropRow = oShape.AddRow(visSectionProp, visRowLast, visTagDefault)
   
    With oShape
        .Section(visSectionProp).Row(intPropRow).NameU = PropName
        .CellsSRC(visSectionProp, intPropRow, visCustPropsLabel).FormulaU = QuoteIt(PropName)
        .CellsSRC(visSectionProp, intPropRow, visCustPropsType).FormulaU = "0"
        .CellsSRC(visSectionProp, intPropRow, visCustPropsFormat).FormulaU = ""
        .CellsSRC(visSectionProp, intPropRow, visCustPropsLangID).FormulaU = "1043"
        .CellsSRC(visSectionProp, intPropRow, visCustPropsCalendar).FormulaU = ""
        .CellsSRC(visSectionProp, intPropRow, visCustPropsPrompt).FormulaU = PropPrompt
        .CellsSRC(visSectionProp, intPropRow, visCustPropsValue).FormulaU = PropValue
        .CellsSRC(visSectionProp, intPropRow, visCustPropsSortKey).FormulaU = ""
    End With
   
ExitHere:
    Exit Function
   
ErrTrap:
    AddShapeProp = Str(Err.Number) & " : " & Err.message
    Resume ExitHere
   
End Function

However it did produce an error which I captured as a .png file but totally unable to attach to this discussion, nor the shape sheet data for the relevant selected shape.


The  error message  was :
System error 438 : Object doesn't  support this object or method

The shape data would  reveal  so much but more unable to attach .png file

[Surrogate]

but totally unable to attach to this discussion

you can save this picture to any popular picture hostings and insert there with syntax like (ie add there embedded picture)

Code

[img]<hyperlink to your picture at picture hosting>[/img]

Which line of code get error ?

[Yacine]

Some thoughts.

• When debugging comment out the error handling, so the debugger stops in the faulty line.
• Use the error handling for "unexpected" errors only, they cost a lot of computation time. Better include tests on the obvious errors - section or row does not exist.
• There's no need spending time on setting default values - the constants that you set - type, format, langID, etc.
• The QuoteIt function is a nice idea, but is it that more efficient than adding these "chr(34)"?

Otherwise, you may test my code:

Code

Option Explicit


Public Function addShapeProp2(ByRef oShape As Visio.Shape, PropName As String, PropPrompt As String, PropValue As String) As String


'On Error GoTo ErrTrap '


    If Not oShape.SectionExists(visSectionProp, visExistsAnywhere) Then
        oShape.AddSection visSectionProp
    End If


    If Not oShape.CellExists("prop." & PropName, visExistsAnywhere) Then
        oShape.AddNamedRow visSectionProp, PropName, visTagDefault
    End If
    
    oShape.Cells("prop." & PropName & ".label").Formula = Chr(34) & PropName & Chr(34)
    oShape.Cells("prop." & PropName & ".prompt").Formula = Chr(34) & PropPrompt & Chr(34)
    oShape.Cells("prop." & PropName).Formula = Chr(34) & PropValue & Chr(34)
    
'ExitHere: '
'    Exit Function '
'ErrTrap: '
'    addShapeProp = "Error in addShapeProp2: " & Str(Err.Number) & " : " & Err.message '
'    Resume ExitHere '
    
End Function


Sub test()
    Dim shp As Shape
    Dim t As String
    
    Set shp = ActiveWindow.Selection(1)
    
    t = addShapeProp2(shp, "Dings", "Input Dings", "Tralala " & Now)
    If Len(t) > 0 Then
        MsgBox "An Error occured: " & t
    Else
        Debug.Print "All fine"
    End If
End Sub

PS: I'm setting automatically the prop field if it does not exist. This behavior may not always be wanted.
So you could add a flag "add_if_missing" as boolean to the parameters list of the function and if the field does not exist, exit with an according message.

[william slaney]

Yacine you are truly a hero.  http://visguy.com/vgforum/Smileys/default/grin.gif

Did note your warning and check if the cellExists before calling to create because some shapes do not need or want this property

Very cool.

Thanks again
William

[william slaney]

One thing I forgot to ask and should have : When I retrieve the value of this property which I assume is

  somestring = oShape.Cells("prop." & PropName).Formula

Do I need to take account of the quotes {chr(34)} added when setting the value and, if so, how?

Thank you

[Yacine]

For this special case, it is
somestring = oShape.Cells("prop." & PropName).ResultStr("")

then
oShape.Cells("prop." & PropName).Formula = chr(34) & somethingelse & chr(34)

But for your future work you may also investigate on
- all the nuances of Result (ResultIU, ResultInt, ... etc.). This will go in combination with prop.type = 2 (number)
- in case of a number you won't need the "chr(34)".
- in case you want to write a formula instead of a value you wont' need the double quotes neither - eg prop.x = "Guard(PinX)"

[william slaney]

The weirdest thing, when the property value is set to ""
   moShape.Cells("Prop." & msUSERPROPNAME).ResultStr(visNoCast) returns "None" and not ""

Setting a listbox value with "None" when it's not part of the list creates an error.
It's easy to trap and deal with or is there another constant other than visNoCast which would prevent Visio going into creative writing mode?

[Yacine]

On my computer it returns "".

Try ResultStr("")