[ajax]

Требуется программка на Visual Basic, считающая максимальное расстояние по горизонтали и вертикали между всеми объектами на чертеже, то есть общие размеры прямогугольной области, занятой фигурами (размерные линии, выноски не учитываются).

[Олег (jr.)]

Сообщение от ajax Требуется программка на Visual Basic, считающая максимальное расстояние по горизонтали и вертикали между всеми объектами на чертеже, то есть общие размеры прямогугольной области, занятой фигурами (размерные линии, выноски не учитываются).

Такой вариант устроит?

Код:

[Выделить все]

Option Explicit


Public Sub BoundingBoxTest()
    Dim pfs As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim varPt As Variant
    Dim i As Long
    Dim maxpt As Variant
    Dim minpt As Variant
    Dim xmin As Double
    Dim ymin As Double
    Dim xmax As Double
    Dim ymax As Double
    Dim coords(0 To 7) As Double
    Dim oPline As AcadLWPolyline

    Set pfs = ThisDrawing.PickfirstSelectionSet

    pfs.Clear

    pfs.SelectOnScreen

    If pfs.Count = 0 Then Exit Sub

    ReDim maxx(0 To pfs.Count - 1) As Double

    ReDim minx(0 To pfs.Count - 1) As Double

    ReDim maxy(0 To pfs.Count - 1) As Double

    ReDim miny(0 To pfs.Count - 1) As Double

    For i = 0 To pfs.Count - 1

        Set oEnt = pfs.Item(i)

        oEnt.GetBoundingBox minpt, maxpt

        minx(i) = CDbl(minpt(0))

        miny(i) = CDbl(minpt(1))

        maxx(i) = CDbl(maxpt(0))

        maxy(i) = CDbl(maxpt(1))

    Next i
    
    Dim minxs As Variant
    
    minxs = SortLess(minx)
    
    xmin = minxs(0)
    
    Dim minys As Variant
    
    minys = SortLess(miny)
 
    ymin = minys(0)
    
    Dim maxxs As Variant
 
    maxxs = SortMore(maxx)
    
   xmax = maxxs(0)
   
   Dim maxys As Variant
    
   maxys = SortMore(maxy)
 
   ymax = maxys(0)
   
coords(0) = CDbl(xmin)
coords(1) = CDbl(ymin)

coords(2) = CDbl(xmax)
coords(3) = CDbl(ymin)

coords(4) = CDbl(xmax)
coords(5) = CDbl(ymax)

coords(6) = CDbl(xmin)
coords(7) = CDbl(ymax)

Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
oPline.Closed = True
oPline.color = acYellow

End Sub


Public Function SortMore(SourceArr As Variant) As Variant

        Dim Check As Boolean
        Dim Elem As Double
        Dim iCount As Integer

        Check = False
        Do Until Check
        Check = True
        For iCount = LBound(SourceArr) To UBound(SourceArr) - 1
        If SourceArr(iCount) < SourceArr(iCount + 1) Then
        Elem = SourceArr(iCount)
        SourceArr(iCount) = SourceArr(iCount + 1)
        SourceArr(iCount + 1) = Elem
        Check = False
        End If
        Next
        Loop
        
SortMore = SourceArr

End Function
Public Function SortLess(SourceArr As Variant) As Variant

        Dim Check As Boolean
        Dim Elem As Double
        Dim iCount As Integer

        Check = False
        Do Until Check
        Check = True
        For iCount = LBound(SourceArr) To UBound(SourceArr) - 1
        If SourceArr(iCount) > SourceArr(iCount + 1) Then
        Elem = SourceArr(iCount)
        SourceArr(iCount) = SourceArr(iCount + 1)
        SourceArr(iCount + 1) = Elem
        Check = False
        End If
        Next
        Loop
        
SortLess = SourceArr

End Function

~'J'~

[ajax]

Работает, за исключением того что размеры и выноски не отсеиваются из выборки

[Олег (jr.)]

Сообщение от ajax Работает, за исключением того что размеры и выноски не отсеиваются из выборки

Добавь логический фильтр чтобы не выбирать
-4 "NOT"> тут размеры и выноски -4 "NOT>"

Типа:

Код:

[Выделить все]

Public Sub BoundingBoxTest()
    Dim pfs As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim varPt As Variant
    Dim ftype(5) As Integer
    Dim fdata(5) As Variant
    Dim dxfCode, dxfValue
    Dim i As Long
    Dim maxpt As Variant
    Dim minpt As Variant
    Dim xmin As Double
    Dim ymin As Double
    Dim xmax As Double
    Dim ymax As Double
    Dim coords(0 To 7) As Double
    Dim oPline As AcadLWPolyline


    ftype(0) = -4: ftype(1) = -4: ftype(2) = 0: ftype(3) = 0: ftype(4) = -4: ftype(5) = -4
    
    fdata(0) = "<not": fdata(1) = "<or": fdata(2) = "DIMENSION": fdata(3) = "LEADER,MLEADER": fdata(4) = "or>": fdata(5) = "not>"
    
    dxfCode = ftype: dxfValue = fdata
    
    Set pfs = ThisDrawing.PickfirstSelectionSet

    pfs.Clear

    pfs.SelectOnScreen dxfCode, dxfValue

    If pfs.Count = 0 Then Exit Sub

    ReDim maxx(0 To pfs.Count - 1) As Double

    ReDim minx(0 To pfs.Count - 1) As Double

    ReDim maxy(0 To pfs.Count - 1) As Double

    ReDim miny(0 To pfs.Count - 1) As Double

    For i = 0 To pfs.Count - 1

        Set oEnt = pfs.Item(i)

        oEnt.GetBoundingBox minpt, maxpt

        minx(i) = minpt(0)

        miny(i) = minpt(1)

        maxx(i) = maxpt(0)

        maxy(i) = maxpt(1)

    Next i
    
    Dim minxs As Variant
    
    minxs = SortLess(minx)
    
    xmin = minxs(0)
    
    Dim minys As Variant
    
    minys = SortLess(miny)
 
    ymin = minys(0)
    
    Dim maxxs As Variant
 
    maxxs = SortMore(maxx)
    
   xmax = maxxs(0)
   
   Dim maxys As Variant
    
   maxys = SortMore(maxy)
 
   ymax = maxys(0)
   
coords(0) = CDbl(xmin)
coords(1) = CDbl(ymin)

coords(2) = CDbl(xmax)
coords(3) = CDbl(ymin)

coords(4) = CDbl(xmax)
coords(5) = CDbl(ymax)

coords(6) = CDbl(xmin)
coords(7) = CDbl(ymax)

Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(coords)
oPline.Closed = True
oPline.color = acYellow

End Sub

МТексты у лидеров не отфильтровываются - здесь
нужен сложный алгоритм через расширенные словари
лидеров и мультилидеров
Я пас...

~'J'~