社区 › VB › 缩放视口

Bryco 发表于 2007-3-5 14:48:49

缩放视口

好的，可能只是星期一，但我无法让这段代码工作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
如果我单步执行，它在第一次通过时有效，但Acad希望再次处理VP，并缩放范围，然后退出
有人知道为什么吗？

Bryco 发表于 2007-3-5 16:49:32

您是否忽略了Paperspace视口本身？

Bryco 发表于 2007-3-5 21:19:41

我不知道&#039；我不认为你可以通过选择集到达那里
试试这个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

Bryco 发表于 2007-3-6 09:03:11

不，我知道我忘了什么&nbsp；我可以看到它激活了它，但大脑没有工作

Bryco 发表于 2007-3-6 09:06:43

Bryco，很好&nbsp；我想我需要更多的咖啡来让大脑运转起来。

Bryco 发表于 2007-3-6 14:21:09

It#039；这一直是一种痛苦，我希望我能找到更好的方法。

Bryco 发表于 2007-3-7 08:30:43

如果稍微更改一下逻辑，您可以进一步整理代码并去掉GOTOs: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.ObjectIDB(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

Bryco 发表于 2007-3-7 08:45:14

干得好DaveR&nbsp；每天学点东西

Bryco 发表于 2007-3-7 10:05:38

本人&#039；我注意到有些人不&#039；t喜欢goto，I&#039；我不知道为什么
我认为它们使代码更容易阅读。

Bryco 发表于 2007-3-7 11:20:30

我认为原因是它有潜力制作意大利面代码&nbsp；如果使用得当，这很好，但也有人认为使用它是不好的做法。

查看完整版本: 缩放视口