本帖最后由 作者 于 2008-5-15 14:23:16 编辑
我没有办法了!只有采用一个很笨的办法,先用一个命令生成边界后再在命令行调用另外一个命令生成填充 Public Sub qt() '快速填充 On Error GoTo err Dim hatchObj As AcadHatch Dim patternName As String Dim PatternType As Long Dim bAssociativity As Boolean Dim outerLoop(0) As AcadEntity ' 定义图案填充 Dim eNt As AcadEntity patternName = "ANSI31" PatternType = 0 bAssociativity = True Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity) ' 当前图纸的实体数目 Dim sset As AcadSelectionSet Set sset = ThisDrawing.SelectionSets.Add("ss") sset.Select acSelectionSetLast'得到最近一次创建的图元 For Each eNt In sset Set outerLoop(0) = eNt Next hatchObj.AppendOuterLoop outerLoop ' 计算并显示图案填充 hatchObj.Evaluate outerLoop(0).Delete ThisDrawing.Regen True err: sset.Delete End Sub Public Sub bb() '快速填充前先画出边界准备 Dim Pt As Variant Pt = ThisDrawing.Utility.GetPoint(, "指定内部点: ") ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "e" & vbCr & vbCr ThisDrawing.SendCommand "qt" & vbCr & Pt(0) & "," & Pt(1) & vbCr & vbCr ' 如果存在边界,则会生成新的实体 End Sub |