乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 12|回复: 0

反射镜舱口,vba

[复制链接]

170

主题

1424

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
2119
发表于 2007-1-31 02:40:28 | 显示全部楼层 |阅读模式
当您在 vba 中镜像图案填充时,生成的新图案填充似乎不是关联的。
如果将镜像的pline对象设置为镜像舱口的外环并获得奇怪的结果(双倍舱口),
我希望其他人已经弄清楚了这一点。我能做的最好的事情就是创建一个新的舱口,而不是模仿它。
  1. Sub MirrorHatch()
  2.     Dim Ent As AcadEntity
  3.     Dim Ent2 As AcadEntity
  4.     Dim oHatch As AcadHatch
  5.     Dim MirrHatch As AcadHatch
  6.     Dim oPline As AcadLWPolyline
  7.     Dim MirrPline(0) As AcadEntity
  8.     Dim Id As Long
  9.     Dim ob(0) As AcadObject
  10.     Dim obs As Variant
  11.     Dim SS As AcadSelectionSet
  12.     Dim P1, P2
  13.     Dim i As Integer
  14.     Dim Zero(2) As Double
  15.    
  16.     P1 = Zero
  17.     P2 = P1
  18.     P2(1) = 1
  19.     Set SS = ThisDrawing.SelectionSets.Add("ss")
  20.     SS.SelectOnScreen
  21.    
  22.     For i = SS.Count - 1 To 0 Step -1
  23.         Set Ent = SS(i)
  24.         If TypeOf Ent Is AcadHatch Then
  25.             Set oHatch = Ent
  26.             If oHatch.AssociativeHatch Then
  27.                 If oHatch.NumberOfLoops = 1 Then
  28.                     oHatch.GetLoopAt 0, obs
  29.                     Debug.Print UBound(obs)
  30.                     If UBound(obs) = 0 Then
  31.                         If TypeOf obs(0) Is AcadLWPolyline Then
  32.                             Id = obs(0).ObjectID
  33.                             For Each Ent2 In SS
  34.                                 If Ent2.ObjectID = Id Then
  35.                                     Set oPline = Ent2
  36.                                     Set MirrPline(0) = oPline.Mirror(P1, P2)
  37.                                     Set MirrHatch = ThisDrawing.ModelSpace.AddHatch(oHatch.PatternType, _
  38.                                                 oHatch.PatternName, True)
  39.                                     MirrHatch.AppendOuterLoop MirrPline
  40.                                     MirrHatch.Layer = oHatch.Layer
  41.                                     MirrHatch.PatternScale = oHatch.PatternScale
  42.                                     MirrHatch.PatternAngle = -oHatch.PatternAngle
  43.                                     MirrHatch.Evaluate
  44.                                     
  45.                                     'Set MirrHatch = oHatch.Mirror(P1, P2)
  46.                                     'MirrHatch.AppendOuterLoop (MirrPline)
  47.                                     
  48.                                     SS.RemoveItems obs
  49.                                     Set ob(0) = Ent
  50.                                     SS.RemoveItems ob
  51.                                     Exit For
  52.                                 End If
  53.                             Next
  54.                         End If
  55.                     End If
  56.                 End If
  57.             End If
  58.         End If
  59.     Next i
  60.     For Each Ent In SS
  61.         Ent.Mirror P1, P2
  62.     Next
  63.    
  64.     SS.Delete
  65. End Sub

这个子工作,但是,
这2行我期望工作
'Set MirrHatch = oHatch.Mirror(P1, P2)
'MirrHatch.AppendOuterLoop (MirrPline)
但是它们的舱口加倍了。

本帖以下内容被隐藏保护;需要你回复后,才能看到!

游客,如果您要查看本帖隐藏内容请回复
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-7 09:06 , Processed in 1.215948 second(s), 54 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表