> Timur
Попробуй для штриховки
Ограничения:
исходный контур штриховки должен представлять
собой замкнутую полилинию
Если будет состоять из отдельных примитивов то
работать не будет
Выбираешь штриховку, затем после ее удаления
указываешь 2 точки контура, используя привязки
Option Explicit
Const pi As Double = 3.14159265358979
Public Sub DivideHatch()
Dim sset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim oHatch As AcadHatch
Set sset = ThisDrawing.PickfirstSelectionSet
sset.Clear
Dim fcode(0) As Integer
Dim fdata(0) As Variant
Dim dxfcode, dxfdata
fcode(0) = 0
fdata(0) = "HATCH"
dxfcode = fcode
dxfdata = fdata
sset.SelectOnScreen dxfcode, dxfdata
If sset.Count = 0 Then
MsgBox "Nothing selected"
End If
If sset.Count > 1 Then
MsgBox "More than one hatch selected"
Exit Sub
End If
Set oEnt = sset.Item(0)
Set oHatch = oEnt
'//
Dim hatLayer As String
Dim patName As String
Dim patType As Long
Dim blnAssoc As Boolean
Dim hatScale As Double
Dim hatAngle As Double
Dim hatCol As Integer
'//
hatLayer = oHatch.Layer
patName = oHatch.patternName
patType = oHatch.PatternType
blnAssoc = oHatch.AssociativeHatch
hatScale = oHatch.PatternScale
hatAngle = oHatch.PatternAngle
hatCol = oHatch.color
'//
oHatch.Delete
'//
Dim p1, p2
With ThisDrawing.Utility
p1 = .GetPoint(, vbCrLf & "Pick the first point: ")
p2 = .GetPoint(p1, vbCrLf & "Pick the second point: ")
'//
Dim mp(2) As Double
mp(0) = (p1(0) + p2(0)) / 2: mp(1) = (p1(1) + p2(1)) / 2: mp(2) = 0#
Dim ang1 As Double, ang2 As Double
ang1 = .AngleFromXAxis(p1, p2) + pi / 2
ang2 = .AngleFromXAxis(p1, p2) - pi / 2
'//
Dim hp1, hp2
hp1 = .PolarPoint(mp, ang1, 1#)
hp2 = .PolarPoint(mp, ang2, 1#)
Dim oLine As AcadLine
Set oLine = ThisDrawing.ModelSpace.AddLine(p1, p2)
'//
Dim oHatch1 As AcadHatch
Dim oHatch2 As AcadHatch
Set oHatch1 = DrawHatch(hp1, hatLayer, patName, patType, blnAssoc, hatScale, hatAngle, hatCol)
Set oHatch2 = DrawHatch(hp2, hatLayer, patName, patType, blnAssoc, hatScale, hatAngle + pi / 2, hatCol)
'//
oLine.Delete
'//
End With
'//
End Sub
' borrowed from the Help file
Public Function DrawHatch(intPt As Variant, hatLayer As String, patName As String, patType As Long, blnAssoc As Boolean, _
hatScale As Double, hatAngle As Double, hatCol As Integer) As AcadHatch
' This example creates an associative hatch in model space.
Dim hatchObj As AcadHatch
On Error GoTo Err_Control
' Create the associative Hatch object in model space
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(patType, patName, blnAssoc)
' add properties
hatchObj.Layer = hatLayer
hatchObj.AssociativeHatch = blnAssoc
hatchObj.PatternScale = hatScale
hatchObj.PatternAngle = hatAngle
hatchObj.color = hatCol
' Create the outer boundary for the hatch
Dim ObjLast As AcadEntity
Dim i As Integer
'Dim intPt As Variant
Dim pstr As String
Dim outerLoop(0) As AcadEntity
i = ThisDrawing.ModelSpace.Count - 1
'intPt = ThisDrawing.Utility.GetPoint(, "Pick the inner point of boundary")
pstr = Replace(CStr(intPt(0)), ",", ".") & "," & Replace(CStr(intPt(1)), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary" & vbCr & pstr & vbCr & vbCr
Set ObjLast = ThisDrawing.ModelSpace.Item(i + 1)
Set outerLoop(0) = ObjLast
' Append the outerboundary to the hatch object, and display the hatch
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
' delete boundary
ObjLast.Delete
ThisDrawing.Regen True
Set DrawHatch = hatchObj
Err_Control:
End Function
~'J'~