摆脱口齿不清或者告诉我哪里出错了Sub CreateNamedViews()
Dim mspace As AcadModelSpace
Dim mviews As AcadViews
Dim elem As Variant
Dim elemBl As Variant
Dim Incview As AcadView
Dim iIndex As Integer
Dim sName As String
Const XValue1 = 15.5 ' associated constant to XScale
Const YValue1 = 9.8125 ' associated constant to YScale
Const XValue2 = 11 ' associated constant to XScale
Const YValue2 = 8.5 ' associated constant to YScale
Const XValue3 = 8.5 ' associated constant to XScale
Const YValue3 = 11 ' associated constant to YScale
Dim X As Double, Y As Double
Dim point1 As Variant
Dim point2(0 To 1) As Double
'On Error Resume Next
Set mspace = ThisDrawing.ModelSpace
Set mviews = ThisDrawing.Views
For Each elem In mviews
elem.Delete
Next
iIndex = 0
For Each elemBl In mspace
If Not elemBl.EntityName = "AcDbBlockReference" Then GoTo Skip
Select Case elemBl.Name
Case "DWGATTRIBUTES", "dwgattributes", "DWGATTRIBUTES2"
X = XValue1: Y = YValue1
Case "IITITLEHA"
X = XValue2: Y = YValue2
Case "IITITLEVA"
X = XValue3: Y = YValue3
Case Else
GoTo Skip
End Select
point1 = elemBl.InsertionPoint
point2(0) = elemBl.XScaleFactor * X + point1(0)
point2(1) = elemBl.YScaleFactor * Y + point1(1)
iIndex = nGetAttributes(elemBl)'Get attribute TagString = PG
If Err.Number0 Then
MsgBox "Error - Block without PG: " & elemBl.Name
Exit Sub
End If
If iIndex = 0 Then
MsgBox "Error - Block without PG: " & elemBl.Name
Exit Sub
End If
Set Incview = ThisDrawing.Views.Add(iIndex)
If Err.Number0 Then
MsgBox "Error - Block already exists: " & iIndex
Exit For
End If
Incview.Width = elemBl.XScaleFactor * X
Incview.Height = elemBl.YScaleFactor * Y
point2(0) = Incview.Width / 2 + point1(0)
point2(1) = Incview.Height / 2 + point1(1)
Incview.Center = point2
Skip:
Next elemBl
End Sub 好的，我们很接近
如果没有现有的视图，该例程将非常有效
如果图形中有视图，但最后一个视图被删除，则例程将弹出
必须在代码的这一部分内：
页:
1
[2]