Nhờ Kiểm Tra Lỗi Chương Trình Vba

[ngoctanvt 0]

Em đang làm chương trình tính sự hiệu quả khi cắt thép tấm để thi công.

 

Trong bản vẽ cắt thép đính kèm theo:

- Các tấm tôn có màu 193

- Các chi tiết cần cắt có màu 20

- Các lỗ khoét của chi tiết có màu 72

Hiệu quả (%) = (tổng diện tích chi tiết cắt - tổng diện tích lỗ khoét) / tổng diện tích tôn * 100

 

Nhưng khi tính tổng diện tích theo từng màu thì ko được. Em muốn lọc các chi tiết theo màu, ko lọc theo layer.

 

Sub Nesting_Percentage()

 

    On Error Resume Next

    

    '-------------------------------

    

    Dim SS2 As AcadSelectionSet

    Dim FilterType2(0 To 7) As Integer

    Dim FilterData2(0 To 7) As Variant

    Dim ToleArea As Double

    Dim PartArea As Double

    Dim HoleArea As Double

    Dim SumToleArea As Double

    Dim SumPartArea As Double

    Dim SumHoleArea As Double

    Dim Percentage As Double

    Dim PolylineObj As AcadLWPolyline

    

    

    '-------------------------------------------------

    Set SS2 = ThisDrawing.SelectionSets("TNT2")

        If Err <> 0 Then

            Err.Clear

            Set SS2 = ThisDrawing.SelectionSets.Add("TNT2")

        Else

            SS2.Clear

        End If

 

    FilterType2(0) = -4: FilterData2(0) = "<AND"

    FilterType2(1) = 0: FilterData2(1) = "LWPolyline"

    FilterType2(2) = -4: FilterData2(2) = "<OR"

    FilterType2(3) = 62: FilterData2(3) = 193

    FilterType2(4) = 62: FilterData2(4) = 20

    FilterType2(5) = 62: FilterData2(5) = 72

    FilterType2(6) = -4: FilterData2(6) = "OR>"

    FilterType2(7) = -4: FilterData2(7) = "AND>"

    

    SS2.SelectOnScreen FilterType2, FilterData2

    

            

    For Each PolylineObj In SS2

        If PolylineObj.TrueColor = 20 Then

            PartArea = PolylineObj.Area

            SumPartArea = SumPartArea + PartArea

        ElseIf PolylineObj.TrueColor = 72 Then

            HoleArea = PolylineObj.Area

            SumHoleArea = SumHoleArea + HoleArea

        ElseIf PolylineObj.TrueColor = 193 Then

            ToleArea = PolylineObj.Area

            SumToleArea = SumToleArea + ToleArea

        End If

    Next PolylineObj

    SS2.Delete

    

    Percentage = Round((SumPartArea - SumHoleArea) / SumToleArea * 100, 2)

    MsgBox "Used: " & CStr(Percentage) & "%"

    

End Sub

 

 

 

http://www.cadviet.com/upfiles/6/57144_cutting.dwg

 

 

[ngoctanvt 0]

File chương trình VBA đây a.

 http://www.cadviet.com/upfiles/6/57144_abc.txt

[gia_bach 1.548]

Thay PolylineObj.TrueColor bằng : PolylineObj.color

 

Tuy nhiên cần chú ý khi đối tượng có màu là ByLayer.

[ngoctanvt 0]

Chương trình đã chạy ok rồi. Em cảm ơn anh gia_bach :)