VBA用HATCH填充Region没效果(Region是由两个region求交集得到的)



已经用Lisp解决了，VBA研究了半天没办法实现

[XML] 纯文本查看 复制代码

(defun c:hre ();
        (command "hatch" "ansi36" "0.05" "0" (ssget (list '(0 . "REGION"))) "")
        (princ)
)

                               
登录/注册后可看大图

如上图，红框框着的部分是由两个Region相交形成的，直接用Hatch的AppendOuterLoop没有效果，除了炸开这个Region获得子Region就没有别的办法了吗？Utility的GetSubEntity只能用户手动选择，有没有可以直接获取所有SubEntity的办法？
我的代码这样

[Visual Basic] 纯文本查看 复制代码

Dim doc As AcadDocument
Set doc = ThisDrawing
Dim ms As AcadModelSpace
Set ms = doc.ModelSpace
Dim ss As AcadSelectionSet
On Error Resume Next
doc.SelectionSets("xxnote20180329").Delete
Set ss = doc.SelectionSets.Add("xxnote20180329")


Dim h As AcadHatch
Set h = ms.AddHatch(acHatchPatternTypePreDefined, _
"ANSI36", True)
h.PatternAngle = 0
h.PatternScale = 0.05

Dim p1(0 To 2) As Double, p2(0 To 2) As Double
Dim fType(0) As Integer, fData(0) As Variant

'p1(0) = pBase(0) + 8: p1(1) = pBase(1) + 2: p1(2) = 0
'p2(0) = pBase(0) + 20: p2(1) = pBase(1) - 4: p2(2) = 0

fType(0) = 0: fData(0) = "REGION"
'fType(1) = 62: fData(1) = 2

'ss.Select acSelectionSetAll, , , fType, fData
ss.SelectOnScreen fType, fData


Dim obs(0) As AcadObject
Set obs(0) = ss.Item(0)
h.AppendOuterLoop obs
h.Evaluate

哪位大佬有什么好办法啊？

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:Drawing3.zip 
下载次数:2  文件大小:17.03 KB 
下载权限: 不限 以上  [免费赚D豆]

newer

你把你这个DWG压缩传上来，有时可能是边界有问题。



newer 发表于 2018-4-9 14:21
你把你这个DWG压缩传上来，有时可能是边界有问题。

附件上传了，大佬帮忙看下，谢谢了。
用cad自带的命令可以填充，但是写程序就不行，程序只能填充单个Region

newer

通过AcBr API 可以获取REGION中的曲线，不过不用VBA，不知道VBA是否可以使用AcBr API.

HATCH是由外部环和内部环组成的，一个环（LOOP）是一个独立的封闭的曲线，你的相交的REGIONS是两个环边界，你实验下，一个边界的REGION应该肯定可以append LOOP,
appendOuterLoop 一次只能添加一个loop, 所以，你要分解得到两个边界才行。

你试试ACTIVEX帮助文件里面的例子

[code=vba]
Sub Example_AppendOuterLoop()
    ' This example creates an associative hatch in model space, and then creates an outer loop for the hatch.
   
    Dim hatchObj As AcadHatch
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
   
    ' Define the hatch
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True
   
    ' Create the associative Hatch object
    Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
   
    ' Create the outer loop for the hatch.
    ' An arc and a line are used to create a closed loop.
    Dim outerLoop(0 To 1) As AcadEntity
    Dim center(0 To 2) As Double
    Dim radius As Double
    Dim startAngle As Double
    Dim endAngle As Double
    center(0) = 5: center(1) = 3: center(2) = 0
    radius = 1
    startAngle = 0
    endAngle = 3.141592
    Set outerLoop(0) = ThisDrawing.ModelSpace.AddArc(center, radius, startAngle, endAngle)
    Set outerLoop(1) = ThisDrawing.ModelSpace.AddLine(outerLoop(0).startPoint, outerLoop(0).endPoint)
        
    ' Append the outer loop to the hatch object, and display the hatch
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate
    ZoomAll
   
End Sub
[/vba]



newer 发表于 2018-4-9 15:57
通过AcBr API 可以获取REGION中的曲线，不过不用VBA，不知道VBA是否可以使用AcBr API.

HATCH是由外部环 ...

单个的是可以的，就是不能填充组合的没办法，我只能拼凑了个lisp执行了

marting

 发表于 2018-4-9 16:57
单个的是可以的，就是不能填充组合的没办法，我只能拼凑了个lisp执行了

appendOutLoop是添加一个封闭的环。所以不要怪函数。

zyclyl

vba的填充功能，我感觉特别不顺手，用起来不方便。。。好无奈

lee50310

这个VBA 程序 执行后会搜寻CAD图内HATCH的数量并将他全部改为淡蓝色

          试试看是否对你有用