v8iss3, vba programming - place point at regular interval on linear elements...

HI  all,

I want tp place points(place active point) along linestrings and shape elements at given interval. I made the below code, it works but not that fine, takes lot of time also dgn file goes hanging...

can someone tell me how can i improve this one? or is this the way this should done? I am a beginner in this area....

'place points at given interval along the linear elements...
'for example if the given interval is 2, then for every 2m a point should be placed on the linestring string from 2 distance...
Private Sub cbPlacePoint_Click()
Dim ee As ElementEnumerator
Dim ele As Element
Dim totCnt As Long, idx As Long, stDis As Double, ptInt As Double, leng As Double
Dim pnt As Point3d

'read interval from the user input
ptInt = tbInterval.Text

'check for input elements selection
If ActiveModelReference.AnyElementsSelected = False Then
MsgBox "Select linear elements and try again.", vbInformation
Exit Sub
End If

On Error GoTo out

Set ee = ActiveModelReference.GetSelectedElements
totCnt = UBound(ee.BuildArrayFromContents) + 1
idx = 0
ee.Reset

'takes the length of the linear elements to repeat point placing....
Do While ee.MoveNext
Set ele = ee.Current
'start point distance also same as interval distance...
stDis = ptInt
If ele.IsLineElement Or ele.IsShapeElement Or ele.IsComplexShapeElement Or ele.IsComplexStringElement Then
If ele.IsLineElement Then
leng = ele.AsLineElement.Length
ElseIf ele.IsShapeElement Then
leng = ele.AsShapeElement.Perimeter
ElseIf ele.IsComplexShapeElement Then
leng = ele.AsComplexShapeElement.Perimeter
ElseIf ele.IsComplexStringElement Then
leng = ele.AsComplexStringElement.Length
End If

'loop until start distance exceeds the length...
Do While stDis < leng
pnt = ele.AsLineElement.PointAtDistance(stDis)
With CadInputQueue
.SendCommand "PLACE POINT"
.SendDataPoint pnt, 1
.SendReset
End With
CommandState.StartDefaultCommand
stDis = stDis + ptInt
Loop
End If

idx = idx + 1
ShowCommand "placing points at interval"
ShowStatus "processing...." & idx & "/" & totCnt

Loop

ShowCommand ""
ShowStatus ""
CommandState.LastView.Redraw
Me.Hide
MsgBox "completed", vbInformation

out:
MsgBox Err.Description, vbCritical, "Error"

End Sub

Thanks in advance...

Parents
  • Hello,

    it is faster to create the LineElement per code than per Command:

    'place points at given interval along the linear elements...
        'for example if the given interval is 2, then for every 2m a point should be placed on the linestring string from 2 distance...
        Dim ee As ElementEnumerator
        Dim ele As Element
        Dim totCnt As Long, idx As Long, stDis As Double, ptInt As Double, leng As Double
        Dim pnt As Point3d
        Dim line As LineElement
    
        'read interval from the user input
        ptInt = tbInterval.Text
        
        'check for input elements selection
        If ActiveModelReference.AnyElementsSelected = False Then
            MsgBox "Select linear elements and try again.", vbInformation
            Exit Sub
        End If
        
        On Error GoTo out
        
        Set ee = ActiveModelReference.GetSelectedElements
        totCnt = UBound(ee.BuildArrayFromContents) + 1
        idx = 0
        ee.Reset
        
        'takes the length of the linear elements to repeat point placing....
        Do While ee.MoveNext
            Set ele = ee.Current
            'start point distance also same as interval distance...
            stDis = ptInt
            If ele.IsLineElement Or ele.IsShapeElement Or ele.IsComplexShapeElement Or ele.IsComplexStringElement Then
                If ele.IsLineElement Then
                    leng = ele.AsLineElement.Length
                ElseIf ele.IsShapeElement Then
                    leng = ele.AsShapeElement.Perimeter
                ElseIf ele.IsComplexShapeElement Then
                    leng = ele.AsComplexShapeElement.Perimeter
                ElseIf ele.IsComplexStringElement Then
                    leng = ele.AsComplexStringElement.Length
                End If
                
                'loop until start distance exceeds the length...
                Do While stDis < leng
                    pnt = ele.AsLineElement.PointAtDistance(stDis)
                    Set line = CreateLineElement2(Nothing, pnt, pnt)
                    ActiveModelReference.AddElement line
                    stDis = stDis + ptInt
                Loop
            End If
            
            idx = idx + 1
            ShowCommand "placing points at interval"
            ShowStatus "processing...." & idx & "/" & totCnt
        Loop
        
        ShowCommand ""
        ShowStatus ""
        CommandState.LastView.Redraw
        Me.Hide
        MsgBox "completed", vbInformation
        
        Exit Sub
    out:
        MsgBox Err.Description, vbCritical, "Error"

    HTH

    Martin

  • Thank you martin,..this works better....
Reply Children
No Data