|
|
在cad 中如果一次选多个实体填充，那么填充出来的块会是一个整体，不能单独编缉，我刚开始想把多义线坐标提出来，然后一个个填充就可以，可是做出来可不是这一回事，因为如果多义线有弧线，就不行了，大家可不可以帮我一下，我想如果直接用send command :bhatch,怎么去掉它的对话框呢？可不可帮我一下，下面是我最初做的程序
Option Explicit
Dim coorDi() As Double
Dim coorDiB() As Double
Dim coorDiC As Variant
Dim j As Integer
Dim lowBiao, upBiao As Integer
Dim appobj As AcadApplication
Dim dwgfile As AcadDocument
Dim i As Integer
Dim sset, ent As Object
Dim hatchObj As AcadHatch
Dim patternName As String
Dim patternType As Long
Dim assocVar As Boolean
Dim outerLoop(0 To 0) As AcadEntity
Sub bhy()
On Error Resume Next '转到错误控制
patternType = 0
patternName = "ANSI31"
assocVar = True
If ThisDrawing.SelectionSets.Count > 0 Then
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Delete
Next i
End If
Set sset = ThisDrawing.SelectionSets.add("ss1")
selec:
sset.SelectOnScreen
For Each ent In sset
Rem j = MsgBox(Err.Number, vbInformation, "fl")
If ent.ObjectName = "AcDbPolyline" Or ent.ObjectName = "AcDbLWPolyline" Then
coorDiB = ent.Coordinates
upBiao = UBound(coorDiB, 1)
ReDim coorDi(upBiao + 2)
coorDiC = ent.Coordinates
For j = 0 To upBiao
coorDi(j) = coorDiC(j)
Next j
coorDi(upBiao + 1) = coorDiC(0)
coorDi(upBiao + 2) = coorDiC(1)
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(patternType, patternName, assocVar)
Set outerLoop(0) = ThisDrawing.ModelSpace.AddLightWeightPolyline(coorDi)
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.Evaluate
End If
Next
Rem ThisDrawing.Regen True
en: End Sub |
|
置顶卡
