Zoom to selected objects

I often use Quick Select to select objects for subsequent manipulation.
However, I would like to see which items I'm about to manipulate. It would
be very cool to have a routine that takes the list of selected objects and
zoom or pan to each object individually. I have searched high & low for an
existing lisp or vba routine that would perform this seemingly desirable
function.

Has anyone created such a function?

It would be similar in functionality to the Zoom to button in the TextFind
command.

--Bill

 

Hi Bill,

I did this for Land Desktop Alignments, but for AutoCAD things it's probably
even easier.

All you need is to get the bounding box of the object and then do a zoom
window based on the bounding box co-ordinates.

--


Laurie Comerford
CADApps
www.cadapps.com.au

 

....Or use AcadApp.ZoomCenter with appropriate object coordinates and zoom
factor (say, 30, for example).

Regards,
Maksim Sestic

 

Hi...

I hope that this routine help you...

Private Sub ZoomTexto()
Dim sSeleccion As AcadSelectionSet
Dim cSeleccion As AcadSelectionSets
Dim vCodigo As Variant
Dim vEntidad As Variant
Dim codigo(0) As Integer
Dim entidad(0) As Variant
Dim ObjTexto As AcadEntity
Dim n As Integer
n = 1
Dim minP1 As Variant, maxP1 As Variant
Form1.Hide
AppActivate autocadApp.Caption
Set cSeleccion = autocadApp.ActiveDocument.SelectionSets
For Each sSeleccion In cSeleccion
If sSeleccion.Name = "SS" Then
sSeleccion.Delete
Exit For
End If
Next
Set sSeleccion = cSeleccion.Add("SS")
codigo(0) = 0
entidad(0) = "TEXT,MTEXT"
vCodigo = codigo
vEntidad = entidad
sSeleccion.SelectOnScreen vCodigo, vEntidad
For Each ObjTexto In sSeleccion
ObjTexto.GetBoundingBox minP1, maxP1
autocadApp.ZoomWindow minP1, maxP1
If n < sSeleccion.Count Then
autocadApp.ActiveDocument.Utility.Prompt vbCr & "Zoom a: " & ObjTexto.TextString & vbCr
Else
autocadApp.ActiveDocument.Utility.Prompt vbCr & "Zoom a: " & ObjTexto.TextString & vbCrLf
autocadApp.ActiveDocument.SendCommand Chr(3)
End If
n = 1 + n
Next ObjTexto
Form1.Show
End Sub

Un saludo de SpeedCAD...
CHILE
FORO: http://www.hispacad.com/foro

 

I've posted the following routine before. It doesn't specifically address what you've asked for, but there are a couple of aspects that could be useful to what you're doing.

I wrote ShowPoint to use when I'm debugging an application and I want to see where a particular issue is occurring. It will draw a coloured sphere at the specified coordinates and then zoom in incrementally to that point so you can get a perspective of where it is in the entire drawing. It does this by specifying a desired ZoomSize and a number of ZoomSteps to get there. Finally it pops up a message box to pause the action but cleverly drags the box out of the way so you can see what you're looking at.

Const X As Byte = 0, Y As Byte = 1, Z As Byte = 2
Const MAXINT As Integer = 32767

Private Sub ShowPoint(ByVal ptv As Variant, Optional ZoomSize As Double = 7500)
Dim Sphere As Acad3DSolid, I As Single, ViewSize As Double, ViewCtr() As Double, StepCount As Byte
Dim OriginalLayer As AcadLayer
Const SphereRadius As Double = 100, ZoomSteps As Integer = 10

Set OriginalLayer = ThisDrawing.ActiveLayer
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Add("Show")
If UBound(ptv) < Z Then ptv = Coord(ptv(X), ptv(Y), 0)
ThisDrawing.ActiveLayer.LayerOn = True
ThisDrawing.SendCommand "shademode" & vbCr & "O" & vbCr
ViewSize = ThisDrawing.GetVariable("VIEWSIZE") ' Rem Could alternatively Name the original view and restore that when finished.
ViewCtr = UCStoWCS(ThisDrawing.GetVariable("VIEWCTR"))
Set Sphere = ThisDrawing.ModelSpace.AddSphere(ptv, SphereRadius)
Sphere.Color = acMagenta
Sphere.Update
For I = 1 To 100: DoEvents: Next I ' Pause for a moment
For I = ViewSize To ZoomSize Step (ZoomSize - ViewSize) / (ZoomSteps - 1)
ZoomCenter Coord(((Sphere.Centroid(X) * StepCount) + (ViewCtr(X) * (ZoomSteps - StepCount))) / ZoomSteps, ((Sphere.Centroid(Y) * StepCount) + (ViewCtr(Y) * (ZoomSteps - StepCount))) / ZoomSteps, ((Sphere.Centroid(Z) * StepCount) + (ViewCtr(Z) * (ZoomSteps - StepCount))) / ZoomSteps), I
Sphere.Update
StepCount = StepCount + 1 ' We want StepCount to be zero on the first iteration to make the Coord code line above clearer
Next I
ZoomCenter Sphere.Centroid, ZoomSize: Sphere.Update
SendKeys "% m{DOWN 52}{RIGHT 72}{ENTER}" ' Drag the subsequent Message Box into the corner so we can see the point
MsgBox ""
Sphere.Delete
Set Sphere = Nothing
ZoomCenter ViewCtr, ViewSize
ThisDrawing.ActiveLayer = OriginalLayer
ThisDrawing.Layers("Show").Delete
End Sub

Private Function Coord(ByVal ptX As Double, ByVal ptY As Double, Optional ByVal ptZ As Double = MAXINT) As Double()
Dim pt() As Double

If ptZ = MAXINT Then
' 2D
ReDim pt(0 To 1)
pt(X) = ptX: pt(Y) = ptY
Else
' 3D
ReDim pt(0 To 2)
pt(X) = ptX: pt(Y) = ptY: pt(Z) = ptZ
End If
Coord = pt()
End Function

Regards

Wayne Ivory
IT Analyst Programmer
Wespine Industries Pty Ltd

 

Forgot this companion routine.

Private Function UCStoWCS(ByVal ptv As Variant) As Variant
If UBound(ptv) < 2 Then ReDim Preserve ptv(LBound(ptv) To 2)
UCStoWCS = ThisDrawing.Utility.TranslateCoordinates(ptv, acUCS, acWorld, False)
End Function


Regards

Wayne