TheSwamp
Code Red => VB(A) => Topic started by: David Hall on March 05, 2007, 02:48:49 PM
-
OK, maybe its just Monday, but I cant get this code to work
Public Sub VPzXP()
On Error GoTo ERR_CONTROL
Dim vp As AcadPViewport
Dim N As Double
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim OBJSELSET As AcadSelectionSet
gpCode(0) = 0
dataValue(0) = "VIEWPORT"
Set OBJSELSET = ThisDrawing.SelectionSets.Add("VPL")
OBJSELSET.Select acSelectionSetAll, , , gpCode, dataValue
For Each vp In OBJSELSET
If vp.DisplayLocked = True Then
vp.DisplayLocked = False
End If
ThisDrawing.MSpace = True
ZoomExtents
N = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
N = 1 / N
ZoomScaled N, 2
ThisDrawing.MSpace = False
vp.DisplayLocked = True
Next
Exit_Here:
Exit Sub
ERR_CONTROL:
Select Case Err.Number
Case "-2145320851"
ThisDrawing.SelectionSets.Item("VPL").Delete
Err.Clear
Resume
Case Else
MsgBox Err.Number
Err.Clear
Resume Exit_Here
End Select
End Sub
If I step through it, it works on the first pass, but then Acad wants to process the VP again, and zooms extents, and quits.
Any takers on why?
-
Are you ignoring the Paperspace Viewport ITSELF?
-
I don't think you can get there from a selectionset.
Try this
Public Sub VPzXP2()
Dim oLayout As AcadLayout
Dim oLayouts As AcadLayouts
Dim B As AcadBlock
Dim Ent As AcadEntity
Dim vp As AcadPViewport
Dim N As Double
Set oLayouts = ThisDrawing.Layouts
For Each oLayout In oLayouts
If UCase(oLayout.Name) = "MODEL" Then GoTo skip
Set B = oLayout.Block
For Each Ent In B
If Not TypeOf Ent Is AcadPViewport Then GoTo skipEnts
If Ent.ObjectID = B(0).ObjectID Then GoTo skipEnts
Set vp = Ent
If vp.DisplayLocked = True Then
vp.DisplayLocked = False
End If
ThisDrawing.ActiveLayout = oLayout
vp.Display True
ThisDrawing.MSpace = True
ZoomExtents
N = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
N = 1 / N
ZoomScaled N, 2
ThisDrawing.MSpace = False
vp.DisplayLocked = True
skipEnts:
Next Ent
skip:
Next oLayout
End Sub
-
Are you ignoring the Paperspace Viewport ITSELF?
DUH, no, I knew there was something I was forgetting. I could see it activating it, but brain no workie
-
Bryco, works great. I guess I needed more coffee to kick brain into gear.
-
It's always been a pain,I wish I could figure out a better way.
-
You can tidy up the code a little further and get rid of the GOTOs if you change the logic a little:
Public Sub VPzXP2()
Dim oLayout As AcadLayout
Dim oLayouts As AcadLayouts
Dim B As AcadBlock
Dim Ent As AcadEntity
Dim vp As AcadPViewport
Dim N As Double
Set oLayouts = ThisDrawing.Layouts
For Each oLayout In oLayouts
If UCase(oLayout.Name) <> "MODEL" Then
Set B = oLayout.Block
For Each Ent In B
If TypeOf Ent Is AcadPViewport Then
If Ent.ObjectID <> B(0).ObjectID Then
Set vp = Ent
If vp.DisplayLocked = True Then
vp.DisplayLocked = False
End If
ThisDrawing.ActiveLayout = oLayout
vp.Display True
ThisDrawing.MSpace = True
ZoomExtents
N = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
N = 1 / N
ZoomScaled N, 2
ThisDrawing.MSpace = False
vp.DisplayLocked = True
End If
End If
Next Ent
End If
Next oLayout
End Sub
-
Nice work DaveR. Learn something everyday :-)
-
I've noticed some people don't like goto, I'm not sure why.
I think they make the code easier to read.
-
I think the reason why is it can have the potential to make spaghetti code. If used properly, its fine, but there are those that think it is bad practice to use it.
-
I typically only use GOTOs when I have to (error trapping for example), because of the spaghetti code possibility. If it works for you then that's fine. I was just presenting an alternative way of doing things. No offense meant.
-
None taken Dave.
I actually go back to my code and add gotos as I like them.
I will however do a speed test on them and see if there is any difference.
-
Bryco's use mirrors mine own sometimes. It's like having a 'break' or 'continue' statemenet available in VB like the real languages do :evil: (couldn't resist)
Cheers,
Glenn.
-
No difference in speed here.(I have a very slow computer)
nogo=24.75456
go=24.69606
See for yourself run MakeSomeObjects then Addemup
Private Sub MakeSomeObjects()
Dim i As Integer, j As Integer
Dim X As Integer, Y As Integer
Dim c As AcadCircle
Dim R As Double
Dim Cen(2) As Double
Dim L As AcadLayer
Dim Ls As AcadLayers
Set Ls = ThisDrawing.LAYERS
For i = 1 To 90
Set L = Ls.Add(i)
L.Color = i
Next
R = 0.45
For j = 0 To 1000
For i = 0 To 89
R = R + 0.001
If Int(i / 10) = i / 10 Then
X = 0: Y = Y + 1
Else
X = X + 1
End If
Cen(0) = X: Cen(1) = Y
Set c = ThisDrawing.ModelSpace.AddCircle(Cen, R)
c.Layer = i + 1
Next i
Next j
End Sub
Private Sub Addemup()
Dim i As Integer
Dim nogo As Single
Dim go As Single
For i = 1 To 10
go = go + speedGoto
nogo = nogo + speedNoGoto
Next
Debug.Print "nogo=" & nogo
Debug.Print "go=" & go
End Sub
Private Function speedNoGoto() As Single
Dim Ent As AcadEntity
Dim T As Single
T = Timer
For Each Ent In ThisDrawing.ModelSpace
If TypeOf Ent Is AcadCircle Then
If Ent.Layer = "90" Then
If Ent.radius > 90 Then
If Ent.radius < 90.5 Then
Debug.Print Ent.radius
Exit For
End If
End If
End If
End If
Next Ent
speedNoGoto = Timer - T
End Function
Private Function speedGoto() As Single
Dim Ent As AcadEntity
Dim T As Single
T = Timer
For Each Ent In ThisDrawing.ModelSpace
If Not TypeOf Ent Is AcadCircle Then GoTo skip
If Ent.Layer <> "90" Then GoTo skip
If Ent.radius < 90 Then GoTo skip
If Ent.radius > 90.5 Then GoTo skip
Debug.Print Ent.radius
Exit For
skip:
Next Ent
speedGoto = Timer - T
End Function