GROUP ĐỐI TƯỢNG SAU KHI KẾT THÚC LỆNH VBA

[sansimese 0]

Em đang tập tành code VBA nhờ các cao nhân chỉ em cách làm với ạ. Hiện tại em viết VBA tạo 1 đoạn thẳng và 1 cái text, sau khi kết thúc lệnh thì group 2 đối tượng lại để tiện di chuyển, kiểm tra sau này. Các đoạn thẳng và text tiếp theo cũng sẽ được GROUP lại. Nhưng khác GROUP đã tạo. Tạo line thì em đã viết được. Tới phần GROUP lại thì em bó tay. T_T

 

[CadExTools 100]

Sub Example_AppendItems()
    ' This example creates a group and several objects.
    ' It then appends the objects to the group.
    
    ' Create the new group
    Dim groupObj As AcadGroup
    Set groupObj = ThisDrawing.Groups.Add("TEST_GROUP")
            
    ' Create a Ray object in model space
    Dim rayObj As AcadRay
    Dim basePoint(0 To 2) As Double
    Dim SecondPoint(0 To 2) As Double
    basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0#
    SecondPoint(0) = 1#: SecondPoint(1) = 3#: SecondPoint(2) = 0#
    Set rayObj = ThisDrawing.ModelSpace.AddRay(basePoint, SecondPoint)
    
    ' Create a polyline object in model space
    Dim plineObj As AcadLWPolyline
    Dim points(0 To 5) As Double
    points(0) = 3: points(1) = 7
    points(2) = 9: points(3) = 2
    points(4) = 3: points(5) = 5
    Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
    plineObj.Closed = True

    ' Create a line object in model space
    Dim lineObj As AcadLine
    Dim startPoint(0 To 2) As Double
    Dim endPoint(0 To 2) As Double
    startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
    endPoint(0) = 2: endPoint(1) = 2: endPoint(2) = 0
    Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)
    
    ' Create a circle object in model space
    Dim circObj As AcadCircle
    Dim centerPt(0 To 2) As Double
    Dim radius As Double
    centerPt(0) = 20: centerPt(1) = 30: centerPt(2) = 0
    radius = 3
    Set circObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)

    ' Create an ellipse object in model space
    Dim ellObj As AcadEllipse
    Dim majAxis(0 To 2) As Double
    Dim center(0 To 2) As Double
    Dim radRatio As Double
    center(0) = 5#: center(1) = 5#: center(2) = 0#
    majAxis(0) = 10: majAxis(1) = 20#: majAxis(2) = 0#
    radRatio = 0.3
    Set ellObj = ThisDrawing.ModelSpace.AddEllipse(center, majAxis, radRatio)

    ZoomAll
    
    ' Iterate through the model space collection.
    ' Collect the objects found into an array of objects
    ' to be added to the group.
    ReDim appendObjs(0 To ThisDrawing.ModelSpace.count - 1) As AcadEntity
    Dim I As Integer
    For I = 0 To ThisDrawing.ModelSpace.count - 1
        Set appendObjs(I) = ThisDrawing.ModelSpace.Item(I)
    Next
    
    ' Add the array of objects to the group
    groupObj.AppendItems appendObjs
    
    ThisDrawing.Regen acActiveViewport
    
End Sub

VBA thì bạn refer code sau nhé:

Groups.txt

[sansimese 0]

với code này thì các đối tượng vẽ sau đều bị gộp vào 1 group ạ, em muốn các đối tượng vẽ sau sẽ tách ra thành group khác ạ

[CadExTools 100]

Code nhanh giúp bạn:

Sub Example_AppendItems()

    Dim groupObj As AcadGroup

    Dim appendObjs(1) As AcadEntity

    

    ' Create a line object in model space

    Dim lineObj As AcadLine

    Dim startPoint As Variant

    Dim endPoint As Variant

    Dim objText As AcadText

    

    On Error GoTo EndSub

    

    Do While Err = 0

        With ThisDrawing.Utility

            startPoint = .GetPoint(, "Pick Start point:")

            endPoint = .GetPoint(startPoint, "Pick Start point:")

        End With

        

        Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

        

        Set objText = ThisDrawing.ModelSpace.AddText(Round(lineObj.Length, 3), lineObj.startPoint, lineObj.Length / 10)

        

        'Create Group with Name = Line Handle

        Set groupObj = ThisDrawing.Groups.Add(lineObj.Handle)

        

        Set appendObjs(0) = lineObj

        Set appendObjs(1) = objText

        

        ' Add the array of objects to the group

        groupObj.AppendItems appendObjs

    Loop

EndSub:

    Err.Clear

End Sub

 

[sansimese 0]

Vào lúc 10/3/2022 tại 15:06, CadExTools đã nói:

Code nhanh giúp bạn:

Sub Example_AppendItems()

    Dim groupObj As AcadGroup

    Dim appendObjs(1) As AcadEntity

    

    ' Create a line object in model space

    Dim lineObj As AcadLine

    Dim startPoint As Variant

    Dim endPoint As Variant

    Dim objText As AcadText

    

    On Error GoTo EndSub

    

    Do While Err = 0

        With ThisDrawing.Utility

            startPoint = .GetPoint(, "Pick Start point:")

            endPoint = .GetPoint(startPoint, "Pick Start point:")

        End With

        

        Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

        

        Set objText = ThisDrawing.ModelSpace.AddText(Round(lineObj.Length, 3), lineObj.startPoint, lineObj.Length / 10)

        

        'Create Group with Name = Line Handle

        Set groupObj = ThisDrawing.Groups.Add(lineObj.Handle)

        

        Set appendObjs(0) = lineObj

        Set appendObjs(1) = objText

        

        ' Add the array of objects to the group

        groupObj.AppendItems appendObjs

    Loop

EndSub:

    Err.Clear

End Sub


 

Cảm ơn anh đã giúp em, dựa vào code của anh em chỉnh lại cho phù hợp với VBA của mình và đã làm được. Cảm ơn anh rất nhiều