社区 › VB › Sset的绝对中心

Bryco 发表于 2008-7-8 23:11:44

A好的
通过将ent=设置为sset，我可以看到这一点；这是一个非常好的主意
我试了一下，但还是没有得到我想要的结果
你知道我做错了什么吗
CADRSub MovefromMidPntofSsetBB()
Dim objEnt As AcadEntity
Dim objSS As AcadSelectionSet
Dim varMinBound As Variant
Dim varMaxBound As Variant
Dim minX As Double, maxX As Double
Dim minY As Double, maxY As Double
On Error Resume Next
ThisDrawing.SelectionSets.Item("GetEnt").Delete
Set objSS = ThisDrawing.SelectionSets.Add("GetEnt")
objSS.SelectOnScreen
Set objEnt = objSS(0)
objEnt.GetBoundingBox varMinBound, varMaxBound
minX = varMinBound(0): maxX = varMaxBound(0)
minY = varMinBound(1): maxY = varMaxBound(1)
For Each objEnt In objSS
   objEnt.GetBoundingBox varMinBound, varMaxBound
   If varMinBound(0) < minX Then minX = varMinBound(0)
   If varMinBound(1) < minY Then minY = varMinBound(1)
   If varMaxBound(0) < maxX Then maxX = varMaxBound(0)
   If varMaxBound(1) < maxY Then maxY = varMaxBound(1)
'Get midpt of Sset
   Dim Midpnt(2) As Double
   Midpnt(0) = (minX + maxX) / 2
   Midpnt(1) = (minY + maxY) / 2
   Dim MoveTopnt As Variant
   MoveTopnt = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
   objEnt.Move Midpnt, MoveTopnt
Next objEnt
objSS.Delete
'Debug.Print "varMinBound(0) = " & varMinBound(0) & " / " & "varMaxBound(1) = " & varMaxBound(1)
'Debug.Print "minX = " & minX & " / " & "maxX = " & maxX
End Sub

Atook 发表于 2008-7-8 23:13:00

是的，Fixo，
我也试了一下你的，发现它不起作用
我想阿托克差不多有了
我试了一下，但我仍然做错了什么，只是不太确定它是什么

Atook 发表于 2008-7-8 23:14:58

还有
我想我想说的是
objSS。移动

Atook 发表于 2008-7-8 23:35:18

&nbsp&nbsp；对于OBJS中的每个objEnt&nbsp&nbsp&nbsp；奥布延特。GetBoundingBox varMinBound、varMaxBound&nbsp&nbsp&nbsp；如果varMinBound（0）&lt；minX-Then minX=varMinBound（0）&nbsp&nbsp&nbsp；如果varMinBound（1）&lt；minY-Then minY=varMinBound（1）&nbsp&nbsp&nbsp；如果varMaxBound（0）&gt；maxX然后maxX=varMaxBound（0）&nbsp&nbsp&nbsp；如果varMaxBound（1）&gt；maxY然后maxY=varMaxBound（1）&nbsp；下一个varMaxBound（1）&nbsp；下一个目标&nbsp；Dim cpt（2）为双精度&nbsp；cpt（0）=（minX+maxX）/2&nbsp；cpt（1）=（minY+maxY）/2&nbsp；ReturnMid=cpt结束函数

Bryco 发表于 2008-7-8 23:59:39

嗯，我&#039；我不完全确定布莱科在这里说什么
我知道你在计算中点，但那还没有得到整个sset
至少我没有尝试任何方法
Dim objEnt As AcadEntity
Dim objSS As AcadSelectionSet
Dim varMinBound As Variant
Dim varMaxBound As Variant
Dim minX As Double, maxX As Double
Dim minY As Double, maxY As Double
On Error Resume Next
ThisDrawing.SelectionSets.Item("GetEnt").Delete
Set objSS = ThisDrawing.SelectionSets.Add("GetEnt")
objSS.SelectOnScreen
Set objEnt = objSS(0)
objEnt.GetBoundingBox varMinBound, varMaxBound
minX = varMinBound(0): maxX = varMaxBound(0)
minY = varMinBound(1): maxY = varMaxBound(1)
For Each objEnt In objSS
   objEnt.GetBoundingBox varMinBound, varMaxBound
   If varMinBound(0) < minX Then minX = varMinBound(0)
   If varMinBound(1) < minY Then minY = varMinBound(1)
   If varMaxBound(0) < maxX Then maxX = varMaxBound(0)
   If varMaxBound(1) < maxY Then maxY = varMaxBound(1)
Next objEnt
   
Dim cpt(2) As Double
cpt(0) = (minX + maxX) / 2
cpt(1) = (minY + maxY) / 2
Midpnt = cpt
   
Dim MoveTopnt As Variant
MoveTopnt = ThisDrawing.Utility.GetPoint(, "Select Destination Point: ")
objSS.Move Midpnt, MoveTopnt
   
objSS.Delete

查看完整版本: Sset的绝对中心