有时行得通有时行不通

Matersammichman · 发表于 2006-6-14 07:07:14

我被迷惑了...有时候这种代码是有效的...有时候不会...任何代码更正，使这一功能的所有时间将不胜感激。TIA:难看:
Private Sub cmdChangeVPortLayer _ Click()
Dim vport As AcadPViewport
Dim ol ayout As acad layout
Dim new layer As acad layer
Set new layer = this drawing。Layers.Add("Viewport")
此绘图。ActiveLayer = newLayer。ActiveLayer.Plottable = False。active layer . color = AC green
me . hide
' On Error Resume Next
用于此绘图中的每个布局。布局
如果oLayout。然后
为oLayout中的每个vport命名“Model”。如果vport，则阻止
'将vport更改为驻留在层“视口”上。图层“视口”，然后
vport。layer = " Viewport "
Else
End If
Next ' choke
End If
Next
End Sub

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

Keith · 发表于 2006-6-14 07:27:27

很多人不知道的一件事是，纸空间本身就是一个视角...

Bryco · 发表于 2006-6-14 09:20:00

它看起来“应该”可以工作，但当然您也可以枚举PS对象或在纸张空间中创建所有视口对象的选择集。可能存在问题的一件事是不规则形状的视口。从程序上讲，它们是被封闭多边形或圆形遮蔽的视口，可能无法识别。

Cathy · 发表于 2006-6-14 09:23:49

我似乎记得Glenn bloke帮我解决了同样的问题。
文件空间视口总是在各个vps之前制作，因此您可以使用它的id。

copy

Public Sub PViewportsLayer(pLayout As AcadLayout)
     Dim pEnt As AcadEntity, id As Long
     For Each pEnt In pLayout.Block
        If TypeOf pEnt Is AcadPViewport Then
            If id = 0 Then
                id = pEnt.ObjectID
            Else
                If pEnt.ObjectID > id Then
                   pEnt.Layer = "Viewport"
                End If
            End If
        End If
    Next
    Set pEnt = Nothing
    Set pLayout = Nothing
End Sub
Sub Thang()
    Dim l As AcadLayout
    ThisDrawing.LAYERS.Add ("Viewport")
    For Each l In ThisDrawing.Layouts
        If l.ModelType = False Then
            PViewportsLayer l
        End If
    Next
End Sub