Topic: scale viewport

[David Hall]

OK, maybe its just Monday, but I cant get this code to work

Code: [Select]

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 SubIf 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?

[Glenn R]

Are you ignoring the Paperspace Viewport ITSELF?

[Bryco]

I don't think you can get there from a selectionset.
Try this

Code: [Select]

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

[David Hall]

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

[David Hall]

Bryco, works great.  I guess I needed more coffee to kick brain into gear.

[Bryco]

It's always been a pain,I wish I could figure out a better way.

[Dave R]

You can tidy up the code a little further and get rid of the GOTOs if you change the logic a little:

Code: [Select]

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


[David Hall]

Nice work DaveR.  Learn something everyday

[Bryco]

I've noticed some people don't like goto, I'm not sure why.
I think they make the code easier to read.

[David Hall]

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.

[Dave R]

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.

[Bryco]

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.

[Glenn R]

Bryco's use mirrors mine own sometimes. It's like having a 'break' or 'continue' statemenet available in VB like the real languages do  (couldn't resist)

Cheers,
Glenn.

[Bryco]

No difference in speed here.(I have a very slow computer)
nogo=24.75456
go=24.69606 
See for yourself run MakeSomeObjects then Addemup

Code: [Select]

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