图案填充和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
**** Hidden Message ***** 所以，看着它，你正在制作一个ucs，其原点在边界框的ll点，从电流旋转180度。 根据您在此处的内容，更新图案填充是对 UCS 进行更改的唯一原因。 如果是这样的话，为什么不吹掉所有的UCS东西，而只是
redim保留pnt1（0到1）
hatchobj.origin = pnt1
hatchobj.patternangle = hatchobj.patternangle + （（PI * 180）/180）
这难道不会给你带来想要的结果吗？ 目的是模仿孵化编辑，出于某种原因，属性变化的顺序使世界上的一切变得不同......我不需要物体专门旋转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没有数学来做到这一点，没有发送键。当通过事件反应堆运行时，这是有害的...
如果您想完全技术化，则在平面中为90，在平面中为-90。尝试一下。如果它是world 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
这是我的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
~'J'~ 谢谢你到目前为止的帮助...我已经设法解决了UCS问题。我仍然讨厌我们不能设置为“世界”而不必创建一个命名的UCS。
让我给你一点关于我在做什么的见解...它可能对你更有意义...
我们使用舱口来表示各种填充模式，从前我们使用各种比例的“线”来表示船板壁板，以及板条壁板，更不用说AR-CONC、AR-B816C等...大约2年前，我分解并定义了我们所有最常见的填充和一些不太常见的填充的自定义舱口模式，以使我们的生活更轻松，更不用说向BOM移动也使这也更容易...区分8"圈和6"圈的最简单方法是在放置舱口时定义比例，然后为BOM检索舱口的比例和大小...但是这导致人们做数学不正确（有些人喊出8"有些人喊出7 1/2"等...）我们现在已经预定义了孵化，这个名字是我们现在所需要的...
无论如何，各种舱口（根据标准）将被放置在它们相关联的各个层上。我们得到了不正确的比例、颜色、层，舱口原点会关闭，使舱口看起来不正确。所以，进入反应堆...
反应堆将抓取舱口项目及其名称，在舱口模式的左下方设置一个UCS，根据预定义的标准设置层、颜色、比例和旋转（我们的石头模式是随机完成的），重新评估舱口，更新实体并最终将UCS恢复到以前的状态。
现在我还有一个任务......
我们有一个金属屋顶的舱口模式，它在方形屋顶上正确对齐，但很多时候我们有一个三角形部分。默认情况下，我使用的是边界框的左下角。当三角形部分在左边时，最好使用边界框的右上角。所以...我想我需要得到外环并找到任意2个点之间最长的垂直平面...
我让反应堆正常工作，除了在评估舱口的新属性时偶尔会出错。“舱口太密集”和“模糊输出”似乎是最大的，尽管舱口规模没有改变。我想更好地理解方法论，这样我就可以解决这个问题。任何见解都将不胜感激。 我对它做得还不够，如果不玩它，就不能真正提供任何见解，而且我也不太可能想出任何你玩它不能得到的东西。
页:
[1]