社区 › VB › 图案填充和UCS原点

Keith™ 发表于 2008-5-6 10:49:14

图案填充和UCS原点

我试图基于图案填充的边界框操纵UCS原点，然后相应地更新图案填充，但我没有取得任何进展
也许我错过了什么，但这一点；“应该”；工作..Dim Pnt1 As Variant
Dim Pnt2 As Variant
Dim XAx(2) As Double
Dim YAx(2) As Double
'Get the bounding box
HatchObj.GetBoundingBox Pnt1, Pnt2
'Get the current UCS so we can reset it
Set UCSOrg = ThisDrawing.ActiveUCS
'Set the direction vectors of the temp UCS
XAx(0) = Pnt1(0): XAx(1) = 0#: XAx(2) = 0#
YAx(0) = 0#: YAx(1) = Pnt1(1): YAx(2) = 0#
'Create a new UCS
Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, XAx, YAx, "temp")
'Set it active
ThisDrawing.ActiveUCS = NewUCS
'Evaluate the hatch --- this should reset the hatch based upon the current UCS, but it doesn't
HatchObj.Evaluate
'Update the object
HatchObj.UpDate
'Reset the previous UCS
ThisDrawing.ActiveUCS = UCSOrg
'Remove our temp UCS
ThisDrawing.UserCoordinateSystems.Item("temp").Delete

Keith™ 发表于 2008-5-6 13:16:15

因此，看一下，您正在创建一个ucs，其原点位于边界框的ll点，与当前旋转180度&nbsp；从这里可以看出，更新图案填充是更改UCS的唯一原因&nbsp；如果是&#039；在这种情况下，为什么不去掉所有UCS的东西，只需重新定义pnt1（0到1）。原点=pnt1。patternangle=hatchobj。图案角度+（（PI*180）/180）
；这不是你想要的结果吗？

Keith™ 发表于 2008-5-6 14:58:02

其目的是模仿hatchedit，出于某种原因，财产变化的顺序决定了世界上的一切……我没有&#039；不需要将对象旋转180度（实际上是90度…）。旋转是无关紧要的，因为我将其设置为随机旋转角度。但我已经更改了它，以便在UCS中不进行旋转，稍后应用旋转…
'Get the hatch
    Set HatchObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
'and the bounding box
    HatchObj.GetBoundingBox Pnt1, Pnt2
'create new UCS
    Set UCSOrg = ThisDrawing.ActiveUCS
'set the vectors
    XAx(0) = Pnt1(0) + 12: XAx(1) = Pnt1(1): XAx(2) = 0#
    YAx(0) = Pnt1(0): YAx(1) = Pnt1(1) + 12: YAx(2) = 0#
'set the new UCS
    Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, XAx, YAx, "temp")
    ThisDrawing.ActiveUCS = NewUCS
'set a constant scale (we can change this to what is needed)
    HatchObj.PatternScale = 48
'make the pattern angle
    HatchObj.PatternAngle = Int((48 * Rnd) + 1)
'assign the changes
    HatchObj.Evaluate
'update the object
    HatchObj.UpDate
'reset the origin
    ThisDrawing.ActiveUCS = UCSOrg
'delete the temp origin
    ThisDrawing.UserCoordinateSystems.Item("temp").Delete
如果我现在只能找到重置的方法；“世界”；UCS，因为它不是命名UCS，并且只有当世界确实处于活动状态时，才可以通过ActiveUCS使用它。显然，VBA在没有发送键的情况下无法做到这一点。当通过事件反应器操作时，这是有害的…

Keith™ 发表于 2008-5-6 15:23:15

如果你想完全掌握技术，可以试一试&nbsp；如果是世界ucs，可能需要加入一个布尔值，并相应地删除末尾的旋转
'Get the hatch
    Set HatchObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
'and the bounding box
    HatchObj.GetBoundingBox Pnt1, Pnt2
'create new UCS
   If ThisDrawing.GetVariable("WORLDUCS") = 1 Then
    With ThisDrawing
    Set UCSOrg = .UserCoordinateSystems.Add( _
    .GetVariable("UCSORG"), _
    .Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
    .Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
    "whirled")
    End With
    Else
    Set UCSOrg = ThisDrawing.ActiveUCS
    End If
'set the vectors
    XAx(0) = Pnt1(0) + 12: XAx(1) = Pnt1(1): XAx(2) = 0#
    YAx(0) = Pnt1(0): YAx(1) = Pnt1(1) + 12: YAx(2) = 0#
'set the new UCS
    Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, XAx, YAx, "temp")
    ThisDrawing.ActiveUCS = NewUCS
'set a constant scale (we can change this to what is needed)
    HatchObj.PatternScale = 48
'make the pattern angle
    HatchObj.PatternAngle = Int((48 * Rnd) + 1)
'assign the changes
    HatchObj.Evaluate
'update the object
    HatchObj.UpDate
'reset the origin
    ThisDrawing.ActiveUCS = UCSOrg
'delete the temp origin
    ThisDrawing.UserCoordinateSystems.Item("temp").Delete

Keith™ 发表于 2008-5-6 15:30:45

这是我的2美分Sub test()
Dim AUcs As AcadUCS
Dim WorldUCS As AcadUCS
Dim NewUCS As AcadUCS
Dim orig(2) As Double
Dim vx(2) As Double
Dim vy(2) As Double
Dim hatchObj As AcadHatch
Dim Pnt1(2) As Double
Dim Pnt2(2) As Double
Set AUcs = ThisDrawing.ActiveUCS
With AUcs
vx(0) = .XVector(0): vx(1) = .XVector(1): vx(2) = .XVector(2)
vy(0) = .YVector(0): vy(1) = .YVector(1): vy(2) = .YVector(2)
orig(0) = .Origin(0): orig(1) = .Origin(1): orig(2) = .Origin(2)
End With
'' just to inform , perhaps extrafluous here
If vx(0) = 1# And vx(1) = 0# And vx(2) = 0# And _
   vy(0) = 0# And vy(1) = 1# And vy(2) = 0# And _
   orig(0) = 0# And orig(1) = 0# And orig(2) = 0# Then
Debug.Print "World UCS"
Set WorldUCS = ThisDrawing.UserCoordinateSystems.Add(orig, vx, vy, "WorldUCS")
Else
orig(0) = 0#: orig(1) = 0#: orig(2) = 0#
vx(0) = 1#: vx(1) = 0#: vx(2) = 0
vy(0) = 0#: vy(1) = 1#: vy(2) = 0#
Set WorldUCS = ThisDrawing.UserCoordinateSystems.Add(orig, vx, vy, "WorldUCS")
End If
''Get the hatch
    Set hatchObj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
''and the bounding box
    hatchObj.GetBoundingBox Pnt1, Pnt2
'create new UCS
    'Set UCSOrg = ThisDrawing.ActiveUCS 'you are already there
'set the vectors
    vx(0) = Pnt1(0) + 12: vx(1) = Pnt1(1): vx(2) = 0#
    vy(0) = Pnt1(0): vy(1) = Pnt1(1) + 12: vy(2) = 0#
'set the new UCS
    Set NewUCS = ThisDrawing.UserCoordinateSystems.Add(Pnt1, vx, vy, "temp")
    ThisDrawing.ActiveUCS = NewUCS
'set a constant scale (we can change this to what is needed)
    hatchObj.PatternScale = 48
'make the pattern angle
    hatchObj.PatternAngle = Int((48 * Rnd) + 1)
'assign the changes
    hatchObj.Evaluate
'update the object
    hatchObj.Update
'reset the origin
    ThisDrawing.ActiveUCS = WorldUCS
'delete the temp origin
    ThisDrawing.UserCoordinateSystems.Item("temp").Delete
End Sub
~&039；J#039~

Keith™ 发表于 2008-5-6 16:28:38

谢谢你到目前为止的帮助…我已经设法克服了UCS的问题。我仍然痛恨我们不能设定为“；“世界”；无需创建命名UCS
让我给你一点关于我正在做的事情的见解。这可能对你更有意义…
我们使用hatch来填充各种填充图案，以前我们使用；“行”；以各种比例表示搭船专用线和board&amp；板条壁板，更不用说AR-CONC、AR-B816C等……大约2年前，我分解并定义了所有最常见填充的自定义图案，以及一些不太常见的填充图案，以使我们的生活更轻松，更不用提向BOM移动也使其更容易……区分8”的最简单方法；搭接和6“；lap本来是在放置图案填充时定义比例，然后检索BOM的图案填充比例和大小。但这导致人们的数学计算不正确（有些人叫8，有些人叫7 1/2等等）。我们现在已经预定义了图案填充，名称就是我们现在需要的全部…
，各种图案填充（按标准）将放置在与其相关的各个层上。我们得到了不正确的比例、颜色、图层，图案填充原点将被关闭，使图案填充看起来不正确。因此，输入reactor…
reactor将抓取图案填充项及其名称，在图案填充的左下角设置UCS，根据预定义标准设置图层、颜色、比例和旋转（我们的石头图案是随机完成的），重新评估图案填充，更新实体，最后将UCS返回到以前的条件
现在我还有一个任务……我们有一个金属屋顶的剖面线图案，它在正方形屋顶上正确对齐，但很多时候我们有三角形截面。默认情况下，我使用边界框的左下角。当三角形部分位于左侧时，最好使用边界框的右上角。所以…我想我需要得到外环并找到任意两点之间最长的垂直面…&lt；返回按键敲击&gt；

Keith™ 发表于 2008-5-7 11:15:37

我的反应堆工作正常，除了偶尔在评估舱口的新属性时出错&引用；图案填充过密“；和“；输出不明确“；似乎是最大的，即使舱口比例没有改变。本人&#039；我想更好地理解方法，以便解决这个问题。如有任何见解，将不胜感激。

Keith™ 发表于 2008-5-8 13:13:52

哈文#039；如果不使用它，我做得还不够，无法真正提供任何见解，我可能也不太可能想出任何你做不到的东西&#039；t通过玩它。

查看完整版本: 图案填充和UCS原点