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
Quote from: william slaney on June 15, 2022, 07:44:04 AM
but it does not meet .CellExistsU().
Which flag do you use as
fExistsLocally in CellExistsU (https://docs.microsoft.com/en-us/office/vba/api/visio.shape.cellexistsu) ?
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.
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
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.
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
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 ?
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 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
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
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)"
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?
On my computer it returns "".
Try ResultStr("")