TheSwamp
Code Red => VB(A) => Topic started by: David Hall on August 07, 2006, 12:23:00 PM
-
Has anyone figured out how the insert block function changed in 07? I keep getting a filer err using this code
ThisDrawing.PaperSpace.InsertBlock inst, "u:\titleblocks\PP-VTITLINFO.DWG", 1, 1, 1, 0
-
as far as I'm aware, the block insert has not changed in 2007.
the filer error normally points to a file problem, not a vba problem.
I assume you have checked the path and block name. ?
we've got some code running in Acad 2000 thru' 2007 ~ same code, no problem
-
it works on the first dwg, then crashes on each and every dwg after that. I have tried pathing, no-pathing, w/ the .dwg and w/o it. It always works on the first dwg and then crashes.
-
I wrote some code a while back for dealing with blocks, but then did not need it and removed it. I was creating the block on the fly and inserting it. I suggest you look to see if an instance of the block exists before you try and insert it.
Public Function BlockExists(BlockName As String) As Boolean
Dim oBlock As AcadBlock
Dim thisdrawing As AcadDocument
'iterate through the Block collection object
Set entity = thisdrawing.Application.ActiveDocument
For Each oBlock In thisdrawing.Blocks
If oBlock.Name Like BlockName & "*" Then
'found a match, so it exist
BlockExists = True
'so, exit the function with True
Exit Function
End If
Next oBlock
'lblock does not exist
BlockExists = False
End Function
Be careful of this line:
If oBlock.Name Like BlockName & "*" Then
For an exact match, modify it to:
If oBlock.Name Like BlockName then '& "*" Then
The code above was originally post in Autodesk's forum for seeing if a layer exists by Bell, R. Robert . I have so many flavors of it now for collection sets.
An important note is that many times if you use the add method, if it exists, it will return the current, so you do not need to check at all. I read that there too, but did not understand until I just wrote some code that was doing it and it did not crash adding layer that existed that way.
Of course you could be seeing a bug in 2007 or something new too.
Sorry I could not be more help.
Here are some of the others I use:
Public Function TextStyleExists(TextStyle As String) As Boolean
Dim oStyle As ACADTextStyle
Dim entity As AcadDocument
'iterate through the Layers collection object
Set entity = thisdrawing.Application.ActiveDocument
For Each oStyle In entity.TextStyles
If LCase(oStyle.Name) Like LCase(TextStyle) Then '& "*" Then
'found a match, so it exist
TextStyleExists = True
'so, exit the function with True
Exit Function
End If
Next oStyle
'layer does not exist
TextStyleExists = False
End Function
Public Function DimStyleExists(DimStyle As String) As Boolean
Dim oStyle As ACADDimStyle
Dim entity As AcadDocument
'iterate through the Layers collection object
Set entity = thisdrawing.Application.ActiveDocument
For Each oStyle In entity.DimStyles
If LCase(oStyle.Name) Like LCase(DimStyle) Then '& "*" Then
'found a match, so it exist
DimStyleExists = True
'so, exit the function with True
Exit Function
End If
Next oStyle
'layer does not exist
DimStyleExists = False
End Function
Public Function GroupExists(grpName As String) As Boolean
Dim oGroup As AcadGroup
Dim thisdrawing As AcadDocument
'Dim entity As AcadDocument
'iterate through the Layers collection object
Set thisdrawing = AutoCAD_Application.ActiveDocument
For Each oGroup In thisdrawing.Groups
If oGroup.Name Like grpName & "*" Then
'found a match, so it exist
GroupExists = True
'so, exit the function with True
Exit Function
End If
Next oGroup
'layer does not exist
GroupExists = False
End Function
Public Function LayerExists(LayerName As String) As Boolean
Dim oLayer As AcadLayer
Dim entity As AcadDocument
'iterate through the Layers collection object
Set entity = thisdrawing.Application.ActiveDocument
For Each oLayer In entity.Layers
If oLayer.Name Like LayerName & "*" Then
'found a match, so it exist
LayerExists = True
'so, exit the function with True
Exit Function
End If
Next oLayer
'layer does not exist
LayerExists = False
End Function
Public Function LayerExists2(LayerName As String) As Boolean
Dim oLayer As AcadLayer
Dim entity As AcadDocument
'iterate through the Layers collection object
Set entity = thisdrawing.Application.ActiveDocument
For Each oLayer In entity.Layers
If oLayer.Name Like LayerName Then '& "*" Then
'found a match, so it exist
LayerExists2 = True
'so, exit the function with True
Exit Function
End If
Next oLayer
'layer does not exist
LayerExists2 = False
End Function
-
it works on the first dwg, then crashes on each and every dwg after that. I have tried pathing, no-pathing, w/ the .dwg and w/o it. It always works on the first dwg and then crashes.
are you sure it's that line that causes the crash ? what is the rest of the code ? and what is the error ?
our code runs through 40 or 50 block insertions with no problem and in essence it's no different from yours
(well, that line anyway)
-
Here is the module
Option Explicit
Public Sub eppictitl()
Dim SysvarName As String
Dim intdata As Long, OBJvp As AcadPViewport
Dim strData As String, inst(0 To 2) As Double, MIDPT(0 To 2) As Double
Dim X As Double, Y As Double
ThisDrawing.ActiveSpace = acPaperSpace
inst(0) = 0: inst(1) = 0: inst(2) = 0
MIDPT(0) = 16.96367147: MIDPT(1) = 12: MIDPT(2) = 0
X = 33.0473
Y = 23.1
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Add("ANNO-TITL")
ThisDrawing.Layers.Item("ANNO-TITL").color = 8
SysvarName = "FILEDIA"
intdata = 1
ThisDrawing.SetVariable SysvarName, intdata
SysvarName = "CMDDIA"
intdata = 1
ThisDrawing.SetVariable SysvarName, intdata
SysvarName = "PROJECTNAME"
strData = "."
ThisDrawing.SetVariable SysvarName, strData
SysvarName = "snapmode"
intdata = "0"
ThisDrawing.SetVariable SysvarName, intdata
SysvarName = "cecolor"
strData = "bylayer"
ThisDrawing.SetVariable SysvarName, strData
SysvarName = "CELTYPE"
strData = "bylayer"
ThisDrawing.SetVariable SysvarName, strData
SysvarName = "CELWEIGHT"
intdata = "-1"
ThisDrawing.SetVariable SysvarName, intdata
ThisDrawing.PaperSpace.AttachExternalReference "u:\titleblocks\pp-vtep.dwg", "pp-vtep", inst, 1, 1, 1, 0, False
Set OBJvp = ThisDrawing.PaperSpace.AddPViewport(MIDPT, X, Y)
OBJvp.Display True
ThisDrawing.Regen acAllViewports
ThisDrawing.MSpace = True
ZoomExtents
ThisDrawing.MSpace = False
ZoomExtents
ThisDrawing.PaperSpace.InsertBlock inst, "PP-VTITLINFO.DWG", 1, 1, 1, 0
ThisDrawing.Regen acAllViewports
ThisDrawing.Save
End Sub
Like you, I have never had any problems inserting blocks until now. When I step through the code using F8, or when I have it break on error, it always highlights that line. It also only crashes when there is more than 1 dwg open.
I told autodesk about the problem, and they were able to repeat the problem if they had more than 1 dwg open. They have esculated it to developement to see what is going on.
-
Well I still have not heard from Autodesk for a solution (BIG Suprise) but I did find a work around that works consistently.
Dim file As String
file = "u:\titleblocks\pp-vtitlinfo.dwg"
ThisDrawing.PaperSpace.InsertBlock inspt, file, 1, 1, 1, 0
by making a variable , it works consistently