塞特的绝对中心
不管选择集中有多少个实体，是否有可能获得选择集的绝对中点？谢谢CAD**** Hidden Message ***** 希望这将使您开始
Option Explicit
Sub GetSelectionCenter()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim xmin As Double, xmax As Double
Dim ymin As Double, ymax As Double
Dim i As Integer
Dim lp(0 To 2) As Double
Dim up(0 To 2) As Double
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set oSset = .Add("TestSet")
End With
oSset.SelectOnScreen
ReDim xcoords(0 To (oSset.Count - 1) * 2) As Double
ReDim ycoords(0 To (oSset.Count - 1) * 2) As Double
For Each oEnt In oSset
Dim minExt As Variant
Dim maxExt As Variant
oEnt.GetBoundingBox minExt, maxExt
xcoords(i) = minExt(0): xcoords(i + 1) = maxExt(0)
ycoords(i) = minExt(1): ycoords(i + 1) = maxExt(1)
i = i + 1
Next
xmin = SortDesc(xcoords)(0): ymin = SortDesc(ycoords)(0)
xmax = SortAsc(xcoords)(0): ymax = SortAsc(ycoords)(0)
lp(0) = xmin: lp(1) = ymin: lp(2) = 0#
up(0) = xmax: up(1) = ymax: up(2) = 0#
Dim minPt As Variant
Dim maxPt As Variant
Dim cpt As Variant
Dim centPt(2) As Double
With ThisDrawing.Utility
minPt = .TranslateCoordinates(lp, acUCS, acWorld, False)
maxPt = .TranslateCoordinates(up, acUCS, acWorld, False)
centPt(0) = (minPt(0) + maxPt(0)) / 2: centPt(1) = (minPt(1) + maxPt(1)) / 2: centPt(2) = 0#
cpt = .TranslateCoordinates(centPt, acUCS, acWorld, False)
End With
'for visualization only:
Dim oCirc As AcadCircle
Set oCirc = ThisDrawing.ModelSpace.AddCircle(cpt, 10)
oCirc.color = acRed
ZoomWindow minPt, maxPt
End Sub
Public Function SortAsc(SourceArr As Variant) As Variant
Dim Check As Boolean
Dim Elem As Double
Dim iCount As Integer
Check = False
Do Until Check
Check = True
For iCount = LBound(SourceArr) To UBound(SourceArr) - 1
If SourceArr(iCount)SourceArr(iCount + 1) Then
Elem = SourceArr(iCount)
SourceArr(iCount) = SourceArr(iCount + 1)
SourceArr(iCount + 1) = Elem
Check = False
End If
Next
Loop
SortDesc = SourceArr
End Function
~'J'~
修复，
我需要仔细看看这个。
可能会与当地人一起运行它，以查看到底发生了什么。
我有一些类似的东西，但不太参与
谢谢
我会看看
CADR “中心”通常意味着圆——我假设你是指包含所有选定实体的多边形的中间……在这种情况下，你需要比已经发布的代码更多的代码和更复杂的代码
但是，如果您正在寻找一个快速而肮脏的函数，这里有一个小函数，它将传递给它的选择集的边界框的x/y求平均值…
，------------------------------------------------
函数SsCenter（objSset作为AcadSelectionSet）作为变量
Dim MinPoint，MaxPoint作为变量，用于BBox返回调用
Dim I，只要，objCount As Long‘各种计数器＜br＞Dim retPoint（1）为双精度’函数将中心的XY＜br＞TIM TotalX返回为双精度，总计为双“动态计数平均值”
“确保将适当的数据作为参数传递…”
如果objSset为空，则退出函数“确保我们有SelSet
objCount=objSset”。如果objCount=0，则计数
然后退出函数“确保选择集
中有东西循环通过，并获得I=0到objCount-1的每个实体的最小/最大值，循环通过并抓取边界框
objSset.Item（I）。GetBoundingBox最小点，MaxPoint＜br＞TotalX＝TotalX+MinPoint（0）+MaxPoint（1）＜br＞下一步，我＜br＞生成一个x/y平均值的双指数安全数组＜br＞retPoint（0）＝TotalX/（objCount*2）：retPoint＝Total/（objCount*2）＜br＞将其作为变量返回 这两种方法都不起作用。
这有助于完成手头的任务！
是“中心”的定义有问题，还是代码无法运行？
我正在寻找整个选择集的绝对中心。
例如，假设从左下角到右上角的所有实体（边界框）都是
0,0到50,50
然后我会寻找设置一个变量来选择点25,25
一旦我抓住了那个点，那么我就可以将整个sset定位到我需要它的位置。
所以，我希望它能工作，无论是一个实体还是15个；我试了又试，但仍然没有运气。
我认为获得左下角是有意义的（如果我知道一种方法）（x和y）最接近0,0的边界框，以及距离0,0最远的边界框（x和y）的最右上点，然后将这2点除以2，这应该会给出所需的答案。
问题是，我如何获得这些值？
谢谢
CADR
啊，最后一件事;我认为我的方法（口头上）是有意义的，但有一个需要考虑;也就是说，如果边界框的点是 - （负）0，0呢？
我想，那么，我们需要首先检查一个值是否
。Sset-Ent.bounding box LL + UR /2
再次，如果有人有一个可以得到这4个点（x和y）的方法，我想我可以做剩下的。
我获取这些值的快速而肮脏的方式看起来像..
Public Function ReturnMid(objSS As AcadSelectionSet) As Variant
Dim objEnt As AcadEntity
Dim varMinBound As Variant
Dim varMaxBound As Variant
Dim minX As Double
Dim minY As Double
Dim maxX As Double
Dim maxY As Double
Set objEnt = objSS(0)
objEnt.GetBoundingBox varMinBound, varMaxBound
minX = varMinBound(0): minY = varMinBound(1)
maxX = varMaxBound(0): maxY = varMaxBound(1)
For Each objEnt In objSS
objEnt.GetBoundingBox varMinBound, varMaxBound
If varMinBound(0)
是的，Fixo，
我也试过你的，发现它不起作用
CADR
页:
[1]
2