• На форуме с 22 декабря 2005г.
  • Сообщений: 1
  • Спасибо: 0

Тема: Как сделать заливку области по точке внутри контура?

Подскажите пожалуйста, как программно сделать заливку области по точке внутри контура, да ещё и с выделением границы в виде полилинии, да ещё и с возможностью менять системную переменную HPGAPTOL(необязательно). Если использовать из среды команду hatch , то там всё это можно ручками настроить, а как сделать из VBA?

  • Мариша
  • Восстановленный участник
  • На форуме с 2 апреля 2006г.
  • Сообщений: 1
  • Спасибо: 0

Re: Как сделать заливку области по точке внутри контура?

Аналогная проблема, подскажите, plz :)

  • На форуме с 10 августа 2004г.
  • Сообщений: 917
  • Спасибо: 5

Re: Как сделать заливку области по точке внутри контура?

> disintegrator
Я не шибко понимаю VBA
Вот наскреб всяко разно с Интернета, но
HPGATOL почему-то не работает, сама переменная
изменяется, а Автокад все равно ругается, что
не нашел нормальную границу, хотя с замкнутыми
контурами все работает (A2005eng.)

Option Explicit
' mixed by Fatty
Sub Ch_Example_Create_Boundary_Hatch()
          Dim oPline As AcadLWPolyline
          Dim oCount As Long
          Dim point2D As Variant
          Dim poinStr As String
          Dim retPnt As Variant
          Dim sysName, kWord, xStr, yStr As String
          Dim oSpace As AcadBlock
On Error GoTo CallMeFatty
          If Err = 0 Then
          If ThisDrawing.ActiveSpace = acModelSpace Then
          Set oSpace = ThisDrawing.ModelSpace
          Else
          Set oSpace = ThisDrawing.PaperSpace
          End If
ThisDrawing.SetVariable "HPGAPTOL", 5#
ThisDrawing.SetVariable "HPNAME", "SOLID"
          kWord = " >> Specify internal point >> "
          ThisDrawing.Utility.InitializeUserInput 128
          retPnt = ThisDrawing.Utility.GetPoint(, kWord)
          xStr = Replace(CStr(retPnt(0)), ",", ".", 1, vbTextCompare)
          yStr = Replace(CStr(retPnt(1)), ",", ".", 1, vbTextCompare)
With ThisDrawing
oCount = oSpace.Count
poinStr = xStr & "," & yStr
.SendCommand "_-boundary" & vbCr & poinStr & vbCr & vbCr
          With oSpace
          If .Count > oCount Then
          Set oPline = .Item(.Count - 1)
          oPline.Highlight (True)
      If TypeOf oPline Is AcadLWPolyline Then
      Dim Loops(0) As AcadEntity
      Set Loops(0) = oPline
      Dim Hatch As AcadHatch
      Set Hatch = .AddHatch(acHatchPatternTypePreDefined, "SOLID", True)
      Hatch.AppendOuterLoop Loops
      Hatch.Evaluate
      oPline.Delete
      ThisDrawing.Regen True
    End If
          End If
          End With
          End With
CallMeFatty:
          MsgBox Err.Description
          End If
End Sub

~'J'~