Copy Prompted Entries to Drawing custom iproperties

[johan.degreef]

I want each timle the titleblock is updated, to copy the prompted entries from the tilteblockto the drawing custom iproperties. I have have found this code and modified it to my naming scheme, but they don't get copied. Can anyone point me in the right direction?

On Error Resume Next
'https://www.cadlinecommunity.co.uk/hc/en-us/articles/203292761
Dim oDoc As DrawingDocument
oDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Dim oPromptEntry

Dim oCurrentSheet
oCurrentSheet = oDoc.ActiveSheet.Name

i = 1
For Each oSheet In oDoc.Sheets
  'i = i+1
  ThisApplication.ActiveDocument.Sheets.Item(i).Activate
       oTitleBlock=oSheet.TitleBlock
    oTextBoxes=oTitleBlock.Definition.Sketch.TextBoxes
    For Each oTextBox In oTitleBlock.Definition.Sketch.TextBoxes
    Select oTextBox.Text
        Case "PTN_DRAWING"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_DRAWING")=oPromptEntry
        Case "PTN_REVISION"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_REVISION")=oPromptEntry
        Case "PTN_TITLE_EN"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_TITLE_EN")=oPromptEntry
        Case "PTN_DESCRIPTION_EN"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_DESCRIPTION_EN")=oPromptEntry

    End Select
    Next
Next

[bradeneuropeArthur]

Are the custom properties PTN-_*** in the drawing available already? Otherwise you need to add them first with either code or manually.

With

.doc.propertyset.item(4).add(***,###)

[bradeneuropeArthur]

Dim textValue As String
    textValue = "Here's some text."
customPropSet.Add(textValue, "TextProp")

[johan.degreef]

Yes they are in the drawing (I added them to my dwg template), but stay empty after running the rule

[bradeneuropeArthur · Accepted solution]

On Error Resume Next
'https://www.cadlinecommunity.co.uk/hc/en-us/articles/203292761
Dim oDoc As DrawingDocument
oDoc = ThisApplication.ActiveDocument
Dim oSheet As Sheet
Dim oPromptEntry

Dim oCurrentSheet
oCurrentSheet = oDoc.ActiveSheet.Name

i = 1
For Each oSheet In oDoc.Sheets
  'i = i+1
  ThisApplication.ActiveDocument.Sheets.Item(i).Activate
       oTitleBlock=oSheet.TitleBlock
    oTextBoxes=oTitleBlock.Definition.Sketch.TextBoxes
    For Each oTextBox In oTitleBlock.Definition.Sketch.TextBoxes
		
    Select oTextBox.Text
		
        Case "<PTN_DRAWING>"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_DRAWING")=oPromptEntry
        Case "<PTN_REVISION>"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_REVISION")=oPromptEntry
        Case "<PTN_TITLE_EN>"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_TITLE_EN")=oPromptEntry
        Case "<PTN_DESCRIPTION_EN>"
            oPromptEntry  =  oTitleBlock.GetResultText(oTextBox)
            iProperties.Value("Custom", "PTN_DESCRIPTION_EN")=oPromptEntry

    End Select
    Next
Next