TheSwamp
Code Red => VB(A) => Topic started by: Biscuits 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.
' 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
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
-
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.
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
-
Thanks Bryco!
Interesting modifications. Still bombing-out though.
-
Include the functions
-
Bryco...
I'm confused. Could you post the complete code as you feel it should be written. I'm getting nowhere on this.
Thanks
-
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.
-
Doh!!
Thought I had included this in my original post.
Seems these days everyday is Monday
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
-
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
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
-
Here is a typical drawing with 4 views already established
-
Just in case..here is how the routine looks now.
' 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
-
2006 and 2008 the lisp does nothing but the code runs fine.
Get rid of the lisp or tell me where it goes wrong.
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
-
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:
Dim mviews As AcadViews
Set mspace = ThisDrawing.ModelSpace
Set mviews = ThisDrawing.Views
For Each elem In mviews
elem.Delete
Next
iIndex = 0