Addition of user property to an existing shape

Started by william slaney, June 15, 2022, 07:44:04 AM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

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


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.
Yacine

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

Quote from: william slaney on June 16, 2022, 03:57:41 AM

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

I wouldn't, visExistsEveryWhere covers all the cases.
Yacine

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

#6
Quote from: william slaney on June 16, 2022, 08:56:24 AMbut 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)
[img]<hyperlink to your picture at picture hosting>[/img]
Which line of code get error ?

Yacine

#7
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:

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.
Yacine

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)"
Yacine

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("")
Yacine