Sset的绝对中心

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

A好的
通过将ent=设置为sset，我可以看到这一点；这是一个非常好的主意
我试了一下，但还是没有得到我想要的结果
你知道我做错了什么吗
CADR

Sub 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
至少我没有尝试任何方法

copy

 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的绝对中心

发表回复

精选推荐