HOW DYNAMICBLOCK EVERYPROPERTY NAME VALUE CHANGE IN VBA ?

[Anonymous]

Plse Help how i change vertical direction stretch value in autocad vba

my code is :

Private Sub CommandButton1_Click()

UserForm1.Hide

With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With
Dim oSset As AcadSelectionSet
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim D1 As String
Dim D2 As String
Dim L1 As ACAD_DISTANCE
Dim L2 As ACAD_DISTANCE
D1 = TextBox1.Text
D2 = TextBox2.Text
L1 = ThisDrawing.Utility.DistanceToReal(D1, acDecimal)
L2 = ThisDrawing.Utility.DistanceToReal(D2, acDecimal)
CL = L1 / 2

ftype(0) = 0: fdata(0) = "INSERT"
Set oSset = ThisDrawing.SelectionSets.Add("SomeSet")
oSset.SelectOnScreen ftype, fdata
Dim oEnt As AcadEntity
Dim blkref As AcadBlockReference
For Each oEnt In oSset
Set blkref = oEnt
If blkref.IsDynamicBlock Then
ChangeDynProperty blkref, "JAI", CL
ChangeDynProperty blkref, "MANI", CL
End If
Next

End Sub

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Click()

End Sub
Public Function GetDynProps(ByVal blkref As AcadBlockReference) As Variant
If Not blkref.IsDynamicBlock Then
GetDynProps = Null
Else
GetDynProps = blkref.GetDynamicBlockProperties
End If
End Function

Public Sub ChangeDynProperty(ByVal blkref As AcadBlockReference, _
ByVal pName As String, ByVal pValue As Variant)
Dim bProps As Variant
bProps = GetDynProps(blkref)
Dim n
For n = 0 To UBound(bProps)
Dim curProp As AcadDynamicBlockReferenceProperty
Set curProp = bProps(n)
On Error Resume Next
If curProp.Name = pName Then
curProp.Value = pValue
End If
If Err Then
Err.Clear
End If
On Error GoTo 0
Next
End Sub

[truss_85]

Try that code it will work. And make sure that you assign propery value allowable values. Because from vba help menu

"DynamicBlockReferenceProperty: No error is returned if the specified property value could not be set. For example, if the property has a list of allowable values or a minimum-maximum range, and the value provided is not in the list or is out of range, no error is returned."

Public Sub dyn_prop(objBlock As AcadBlockReference)

Dim dyn_properties() As AcadDynamicBlockReferenceProperty
Dim var_atts As Variant

var_atts = objBlock.GetDynamicBlockProperties
    
    For i = LBound(var_atts) To UBound(var_atts)
        If var_atts(i).PropertyName = "name_of_property" Then
            var_atts(i).Value = value_of_property
            MsgBox (var_atts(i).PropertyName & vbNewLine & var_atts(i).Value)
        End If
    Next

End Sub

[Anonymous]

Thank you truss , but it did not work truss ,i attached drawing file and program file  truss plse check and correct it check

i have lot of work for this type of drawing.so plse correct it truss plse help truss.(i know little knowledge in vba)

[truss_85]

wow you say truss 5 times  🙂

here is the code you needed it works fine.

Public Sub block_dyn()

Dim objBlock As AcadBlockReference

Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim ssetObj As AcadSelectionSet
                
On Error Resume Next
ThisDrawing.SelectionSets.Item("SS1").Delete
Set ssetObj = ThisDrawing.SelectionSets.Add("SS1")

FilterType(0) = 0
FilterData(0) = "INSERT"
ssetObj.SelectOnScreen FilterType, FilterData

For Each Item In ssetObj
    If objBlock.EffectiveName = "TEST" Then
        Set objBlock = ssetObj.Item(n)
        Call dyn_prop(objBlock, "Distance1", 50)
        Call dyn_prop(objBlock, "Distance2", 100)
    End If
Next

End Sub

Public Sub dyn_prop(objBlock As AcadBlockReference, name_of_property As String, value_of_property As Double)

Dim dyn_properties() As AcadDynamicBlockReferenceProperty
Dim var_atts As Variant

var_atts = objBlock.GetDynamicBlockProperties

    For i = LBound(var_atts) To UBound(var_atts)
        If var_atts(i).PropertyName = name_of_property Then
            var_atts(i).Value = value_of_property
        End If
    Next

End Sub

[Anonymous]

1000000000 times thanks truss its work good.

[truss_85]

Glad it to work. Any time you need.