• На форуме с 11 ноября 2013г.
  • Сообщений: 2
  • Спасибо: 0

Тема: Помогите закрасить объект

Помогите закрасить объект такого типа как на рисунке. Объект создается из двух дуг и двух линий. Как правильно воспользоваться этими методами AppendInnerLoop, AppendOuterLoop? Заранее огромное спасибо! http://s019.radikal.ru/i643/1311/80/cd31021734ca.jpg

  • На форуме с 11 ноября 2013г.
  • Сообщений: 2
  • Спасибо: 0

Re: Помогите закрасить объект

Я так понял нужно создать регион, ну как его создать больше чем из двух объектов  :?:

  • fixo
  • fixo
  • Активный участник
  • Откуда: СПб
  • На форуме с 7 февраля 2009г.
  • Сообщений: 869
  • Спасибо: 41

Re: Помогите закрасить объект

Для этого не обязательно создавать регион,
можно просто объединить линии и арки в полилинию,
потом ее заштриховать, к примеру:

Option Explicit

Sub JoinArcsAndLines()

Dim oSsets As AcadSelectionSets
Dim oSset As AcadSelectionSet
Dim fType(0) As Integer
Dim fData(0) As Variant
Dim varPt As Variant
Dim oLine As AcadEntity
Dim oEnt As AcadEntity
Dim commStr As String
Dim intPt As Variant


On Error GoTo Error_Trapp

Set oSsets = ThisDrawing.SelectionSets

fType(0) = 0: fData(0) = "LINE,ARC"

For Each oSset In oSsets

If oSset.Name = "LineSet" Then

oSset.Delete

End If

Next

Set oSset = oSsets.Add("LineSset")

oSset.SelectOnScreen fType, fData

ThisDrawing.SetVariable "PEDITACCEPT", 1

commStr = "_PEDIT _M"
 
For Each oLine In oSset

commStr = commStr & " (handent " & Chr(34) & oLine.Handle & Chr(34) & ")"

Next oLine

commStr = commStr & vbCr & " j 0.0000 " & vbCr

ThisDrawing.SendCommand commStr

SendKeys "{ESC}"

oSset.Delete

Set oSset = Nothing

Error_Trapp:

MsgBox Err.Number & Err.Description

End Sub

Дальше смотри пример из Help файла

  • На форуме с 12 февраля 2009г.
  • Сообщений: 26
  • Спасибо: 0

Re: Помогите закрасить объект

Sub Test_Hath()
Dim acdSS As AcadSelectionSet
Dim avarRetPnt As Variant
Dim arrPnts(0 To 11) As Double
Dim acdHtch As AcadHatch
Dim aobjLoop() As AcadEntity
Dim i As Long

On Error Resume Next
 
avarRetPnt = ThisDrawing.Utility.GetPoint(, "Укажите первый угол: ")
arrPnts(0) = avarRetPnt(0): arrPnts(1) = avarRetPnt(1): arrPnts(2) = avarRetPnt(2)
avarRetPnt = ThisDrawing.Utility.GetCorner(avarRetPnt, "Укажите второй угол: ")
arrPnts(3) = arrPnts(0): arrPnts(4) = avarRetPnt(1): arrPnts(5) = avarRetPnt(2)
arrPnts(6) = avarRetPnt(0): arrPnts(7) = avarRetPnt(1): arrPnts(8) = avarRetPnt(2)
arrPnts(9) = avarRetPnt(0): arrPnts(10) = arrPnts(1): arrPnts(11) = avarRetPnt(2)

    For Each acdSS In ThisDrawing.SelectionSets
        If acdSS.Name = "NewSelSet" Then acdSS.Delete
    Next acdSS

Set acdSS = ThisDrawing.SelectionSets.Add("NewSelSet")
acdSS.SelectByPolygon acSelectionSetCrossingPolygon, arrPnts
    If acdSS.Count > 0 Then
        ReDim aobjLoop(0 To acdSS.Count - 1) As AcadEntity
            For i = 0 To acdSS.Count - 1
                Set aobjLoop(i) = acdSS.Item(i)
            Next i
        Set acdHtch = ThisDrawing.ModelSpace.AddHatch(1, "SOLID", True)
        acdHtch.AppendOuterLoop aobjLoop
        acdHtch.Evaluate
    End If
ThisDrawing.Regen acAllViewports

Erase avarRetPnt
Erase arrPnts
Erase aobjLoop
acdSS.Delete
Set acdSS = Nothing
Set acdHtch = Nothing
End Sub