Author Topic: Acad 2007 file update?  (Read 3189 times)

0 Members and 1 Guest are viewing this topic.

Biscuits

  • Swamp Rat
  • Posts: 502
Acad 2007 file update?
« on: April 02, 2007, 11:11:07 AM »
The following routine finds all model views, strips them of their names, and renames them based on attributes. The routine was created when we were using Acad 2002 and worked great.

Code: [Select]

' 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.Number  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.Number  0 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.Number  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.Number  0 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.Number  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.Number  0 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




 Now we have Acad2007 and it bombs out after assigning "view 1" leaving this error message


Code: [Select]

Error-Block without PG: DWGATTRIBUTES


Using ACAD2007, I've tested this on drawings where this worked in ACAD2002. The problem has to be our updating to 2007.
Can anyone determine what we need to do to correct this? I'm stumped!

Thanks

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Acad 2007 file update?
« Reply #1 on: April 02, 2007, 11:21:15 PM »

Biscuits the function that bombs isn't included.
I rewrote the code to show you the use of select case as it was ruining my beer.



Code: [Select]
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
        End Select
           
        point1 = elemBl.InsertionPoint
        point2(0) = elemBl.XScaleFactor * X + point1(0)
        point2(1) = elemBl.YScaleFactor * Y + point1(1)

        iIndex = 1 ' = nGetAttributes(elemBl) 'Get attribute TagString = PG
        If Err.Number <> 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.Number <> 0 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

Biscuits

  • Swamp Rat
  • Posts: 502
Re: Acad 2007 file update?
« Reply #2 on: April 05, 2007, 02:24:17 PM »
Thanks Bryco!

Interesting modifications. Still bombing-out though.

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Acad 2007 file update?
« Reply #3 on: April 05, 2007, 04:05:47 PM »
Include the functions

Biscuits

  • Swamp Rat
  • Posts: 502
Re: Acad 2007 file update?
« Reply #4 on: April 09, 2007, 12:01:25 PM »
Bryco...
I'm confused. Could you post the complete code as you feel it should be written. I'm getting nowhere on this.

Thanks

DaveW

  • Guest
Re: Acad 2007 file update?
« Reply #5 on: April 09, 2007, 02:19:42 PM »
I think Bryco is asking you post the functions that are missing. His sentences are somewhat incomplete, so you never really know. At a quick glance I do not see any calls for externaol function is your code,,,, but whatever. If there are none, then perhaps you have break on all error checked instead of bear on unhandled errors.
« Last Edit: April 09, 2007, 02:24:28 PM by DaveW »

Biscuits

  • Swamp Rat
  • Posts: 502
Re: Acad 2007 file update?
« Reply #6 on: April 09, 2007, 04:44:31 PM »
Doh!!
Thought I had included this in my original post.
Seems these days everyday is Monday


Code: [Select]

Function nGetAttributes(element)

 Dim ArrayAttributes As Variant
 Dim I As Integer
 
 ArrayAttributes = element.GetAttributes
 nGetAttributes = 0
 For I = LBound(ArrayAttributes) To UBound(ArrayAttributes)
    If (ArrayAttributes(I).TagString = "PG" Or ArrayAttributes(I).TagString = "PG1" Or ArrayAttributes(I).TagString = "2" Or ArrayAttributes(I).TagString = "PAGE_NO.") Then
        nGetAttributes = ArrayAttributes(I).TextString
        Exit Function
    End If

 Next

End Function

Bryco

  • Water Moccasin
  • Posts: 1882
Re: Acad 2007 file update?
« Reply #7 on: April 10, 2007, 01:27:31 AM »
Biscuits you may need to post a dwg as I don't know what you have in those atts, your code doesn't crash for me acad2006 although
Dim mspace As AcadModelSpace looks dubious for 2007
Code: [Select]
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

  • Swamp Rat
  • Posts: 502
Re: Acad 2007 file update?
« Reply #8 on: April 10, 2007, 03:11:32 PM »
Here is a typical drawing with 4 views already established

Biscuits

  • Swamp Rat
  • Posts: 502
Re: Acad 2007 file update?
« Reply #9 on: April 10, 2007, 03:16:08 PM »
Just in case..here is how the routine looks now.

Code: [Select]

' 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 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
        End Select
           
        point1 = elemBl.InsertionPoint
        point2(0) = elemBl.XScaleFactor * X + point1(0)
        point2(1) = elemBl.YScaleFactor * Y + point1(1)

        iIndex = 1 ' = nGetAttributes(elemBl) 'Get attribute TagString = PG
        If Err.Number <> 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.Number <> 0 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


Bryco

  • Water Moccasin
  • Posts: 1882
Re: Acad 2007 file update?
« Reply #10 on: April 11, 2007, 12:02:21 AM »
2006 and 2008 the lisp does nothing but the code runs fine.
Get rid of the lisp or tell me where it goes wrong.

Code: [Select]
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.Number <> 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.Number <> 0 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

Biscuits

  • Swamp Rat
  • Posts: 502
Re: Acad 2007 file update?
« Reply #11 on: April 11, 2007, 12:16:19 PM »
Ok. were close!

The routine will work great providing there are no existing views.

If there are views within the drawing all but the last one is deleted then the routine will bomb-out.

Has to be within this part of the code:

Quote

 Dim mviews As AcadViews

 Set mspace = ThisDrawing.ModelSpace
 Set mviews = ThisDrawing.Views

    For Each elem In mviews
        elem.Delete
    Next
    iIndex = 0