社区 › VB › Acad 2007 文件更新？

Biscuits 发表于 2007-4-2 11:11:07

Acad 2007 文件更新？

下面的例程查找所有模型视图，去掉它们的名称，并根据属性重命名它们。该例程是在我们使用Acad 2002时创建的，非常有效

' Author: Wellington Gomes - Darby Anderson
Option Explicit
Sub CreateRunAutoNamedView()
    ThisDrawing.SendCommand ("(defun C:RunAutoNamedView () (setvar ""filedia"" 0) (command ""_VBARUN"" ""CreateNamedViews"") (setvar ""filedia"" 1) )" & vbCr)
End Sub
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 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 elemBl.EntityName = "AcDbBlockReference" Then
'''''''''''''
            If (elemBl.Name = "DWGATTRIBUTES" Or elemBl.Name = "dwgattributes" Or elemBl.Name = "DWGATTRIBUTES2") Then
   
                point1 = elemBl.InsertionPoint
                point2(0) = elemBl.XScaleFactor * XValue1 + point1(0)
                point2(1) = elemBl.YScaleFactor * YValue1 + 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 * XValue1
                Incview.Height = elemBl.YScaleFactor * YValue1
                point2(0) = Incview.Width / 2 + point1(0)
                point2(1) = Incview.Height / 2 + point1(1)
                Incview.Center = point2
'    Incview.Update
            End If
'''''''''''''''''''''''
            If (elemBl.Name = "IITITLEHA") Then
   
                point1 = elemBl.InsertionPoint
                point2(0) = elemBl.XScaleFactor * XValue2 + point1(0)
                point2(1) = elemBl.YScaleFactor * YValue2 + 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 * XValue2
                Incview.Height = elemBl.YScaleFactor * YValue2
                point2(0) = Incview.Width / 2 + point1(0)
                point2(1) = Incview.Height / 2 + point1(1)
                Incview.Center = point2
'    Incview.Update
            End If
'''''''''''''''''''''''
            If (elemBl.Name = "IITITLEVA") Then
   
                point1 = elemBl.InsertionPoint
                point2(0) = elemBl.XScaleFactor * XValue3 + point1(0)
                point2(1) = elemBl.YScaleFactor * YValue3 + 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 * XValue3
                Incview.Height = elemBl.YScaleFactor * YValue3
                point2(0) = Incview.Width / 2 + point1(0)
                point2(1) = Incview.Height / 2 + point1(1)
                Incview.Center = point2

现在我们有了Acad2007，它在分配“视图1”后爆炸，并留下此错误消息

Error-Block without PG: DWGATTRIBUTES

使用ACAD2007，我在ACAD2002中使用的图纸上测试了这一点。问题在于我们更新到2007年。
有人能确定我们需要做什么来纠正这一点吗？我被难住了 0 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

Bryco 发表于 2007-4-2 23:21:15

谢谢布莱科 0 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
Function nGetAttributes(element) As Integer
    Dim ArrayAttributes As Variant
    Dim I As Integer, Num
   
    ArrayAttributes = element.GetAttributes
    For I = LBound(ArrayAttributes) To UBound(ArrayAttributes)
      Select Case ArrayAttributes(I).TagString
            Case "PG", "PG1", "2", "PAGE_NO."
                Num = ArrayAttributes(I).TextString
                If IsNumeric(Num) Then
                  nGetAttributes = Int(Num)
                End If
                Exit Function
       End Select
   
    Next
End Function

Biscuits 发表于 2007-4-5 14:24:17

2006 年和 2008 年，lisp 除了代码运行良好之外什么都不做。
摆脱lisp或告诉我哪里出了问题。
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

Bryco 发表于 2007-4-5 16:05:47

还行，离得很近！
如果没有现有的视图，例程将很好地工作。
如果图形中存在除最后一个视图之外的所有视图都被删除，则例程将爆炸。
必须在代码的这一部分中：

查看完整版本: Acad 2007 文件更新？