TheSwamp
Code Red => VB(A) => Topic started by: lambwill on June 28, 2006, 08:14:50 AM
-
Hi there, this is my first post here so hello all - nice to meet you :)
Now down to business:
I'm trying to write a macro that will fix a very messy bunch of drawings that I have inherited. For the most part I have this Macro running sweet and saving me a ton of time & stress, however I have one sticking point. As I have inherited these drawings form another location, all of my xref paths are broken. Of course this can easily be fixed using the "PROJECTNAME" variable to change the search path for missing xrefs and reloading all of them, however some xrefs are referenced but unloaded and need to stay that way. I've been searching around for a way to differentiate between an xref which is unloaded, and one with a broken path (i.e. 'not found') but I can't find a way anywhere. The majority of my programming experience is with VBA, so a solution in this language would be best - but I have enough experience in LISP to understand it if need be.
Thanks in advance for any help
-
Here is something that I wrote several years ago (and haven't looked at since :) ). So I don't remember how well it worked then and don't know if it will work now, but it may get you started.
Option Explicit
Public Enum XRefStatus
xrloaded = 1
xrdetached = 2
xrNotFound = 3
End Enum
Public Sub test()
Dim colBlocks As AcadObject
Dim objBlock As AcadBlock
Dim objXRefDbase1 As AcadDatabase
Dim objXRefDbase2 As AcadDatabase
Dim objXref As AcadExternalReference
Dim varXref() As Variant
Dim intCount As Integer
Set colBlocks = Me.Blocks
For Each objBlock In colBlocks
If objBlock.IsXRef Then
Select Case GetXRefStatus(objBlock)
Case 1 'xrloaded
MsgBox "Xref " & objBlock.Name & " is Loaded"
Case 2 'xrdetached
MsgBox "Xref " & objBlock.Name & " is Detached"
Case 3 'xrnotfound
MsgBox "Xref " & objBlock.Name & " was not found"
Case Else
MsgBox "Xref " & objBlock.Name & " has me confused"
End Select
End If
Next objBlock
End Sub
Public Function GetXRefStatus(pXRef As AcadBlock) As XRefStatus
Dim xStatus As XRefStatus
Dim objTestObj As Object
On Error GoTo XRefStatus_Error
If pXRef.Count > 1 Then
GetXRefStatus = xrloaded
Exit Function
End If
If pXRef.Count = 1 Then
If pXRef(0).ObjectName = "AcDbText" Then
If pXRef(0).TextString Like "*" & pXRef.Name & "*" Then
GetXRefStatus = xrNotFound
Exit Function
Else ' it only has one item, and that item is text
GetXRefStatus = xrloaded
Exit Function
End If
Else ' it only has one object in it, but that item isnt text
GetXRefStatus = xrloaded
Exit Function
End If
End If
If pXRef.Count = 0 Then 'either unloaded or empty xref
'unloaded xrefs have no database so this will raise an error
Set objTestObj = pXRef.XRefDatabase
GetXRefStatus = xrloaded ' if it gets to here, then the xref is attached but
Exit Function ' contains no objects
End If
XRefStatus_Error:
Select Case Err.Number
Case -2145386390 ' no database error
GetXRefStatus = xrdetached
Err.Clear
Exit Function
Case Else
MsgBox Err.Number
Debug.Print "Error " & Err.Number
Err.Clear
Exit Function
End Select
End Function
-
I had to change the 'Me' to 'ThisDrawing' in line 15 (Set colBlocks = Me.Blocks) to get it to work for me, but that my friend may very well be just the bit of code I was looking for!
Thank you very much :)
-
You're welcome. Hope it helps
-
See this (http://www.theswamp.org/index.php?topic=4103.msg49009#msg49009) post from this thread (http://www.theswamp.org/index.php?topic=4103.msg48939#msg48939). Best of luck coding a pure vb[a] equivalent that utilizes dxf group code 71.
PS: Welcome to the swamp.
:)
-
I remember that Dave. You did that for me on a similar question.
-
See this (http://www.theswamp.org/index.php?topic=4103.msg49009#msg49009) post from this thread (http://www.theswamp.org/index.php?topic=4103.msg48939#msg48939). Best of luck coding a pure vb[a] equivalent that utilizes dxf group code 71.
I have to say, that thread went right over my head. Thankfully Dave's code fitted the bill perfectly, so I won't give my self a hernia attempting to understand it right now. Is there a significant advantage in using LISP in this situation?
-
Is there a significant advantage in using LISP in this situation?
It's prettier? Just kidding.
As I read it: in vb it's deductive, in lisp it's definitive. In the end that may be only academic and of no consequence to your solution.
-
I agree with MP. The code I posted is based on some undocumented conditions that worked at the time and could change and may not be valid for every situation. It was just a quickie that seemed to work.
The values lot of the bit-code could change too, I guess. But one hopes that AutoDesk would document them.
-
What a great way to spend a few rainy hours!! Sure beats working.
Here is a VBA routine thats uses the 70 and 71 codes for xref status. It requires a rereference to the VLisp ActiveX Module (vl16.tlb for version 2004, 2005, 2006, in the AutoCAD installation folder. On my computer, anyway. You may have to search for it)
I haven't fully tested it, but it appears to work in the testing that I have done.
Public Sub XRefTest2()
Dim colBlocks As AcadObject
Dim objBlock As AcadBlock
Dim testBlock As AcadObject
Dim Flag70 As Variant
Dim Flag71 As Variant
Dim sHandle1 As String
Dim sHandle2 As String
Dim sBlockName As String
Set colBlocks = Me.Blocks
For Each objBlock In colBlocks
If objBlock.IsXRef Then
sHandle1 = "&H" + objBlock.Handle
sBlockName = objBlock.Name
sHandle2 = Hex(sHandle1 + 1)
Set testBlock = ThisDrawing.HandleToObject(sHandle2)
Flag70 = vbAssoc(testBlock, 70)
Flag71 = vbAssoc(testBlock, 71)
If Flag71 = "1" Then
MsgBox sBlockName & " appears to be UNLOADED "
ElseIf (Val(Flag70) And 32) = 32 Then MsgBox sBlockName & " appears to be LOADED and RESOLVED "
ElseIf (Val(Flag70) And 4) = 4 Then MsgBox sBlockName & " appears to be NOT FOUND "
End If
End If
Next objBlock
End Sub
Public Function vbAssoc(pAcadObj As AcadObject, pDXFCode As Integer) As Variant
Dim VLisp As Object
Dim VLispFunc As Object
Dim varRetVal As Variant
Dim obj1 As Object
Dim obj2 As Object
Dim strHnd As String
Dim strVer As String
Dim lngCount As Long
Dim i As Long
Dim j As Long
On Error GoTo vbAssocError
strHnd = pAcadObj.Handle
If Me.Application.Version = "16.0" Then
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Else
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
End If
Set VLispFunc = VLisp.ActiveDocument.Functions
Set obj1 = VLispFunc.Item("read").funcall("pDXF")
varRetVal = VLispFunc.Item("set").funcall(obj1, pDXFCode)
Set obj1 = VLispFunc.Item("read").funcall("pHandle")
varRetVal = VLispFunc.Item("set").funcall(obj1, strHnd)
Set obj1 = VLispFunc.Item("read").funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
vbAssoc = varRetVal
'clean up the newly created LISP symbols
Set obj1 = VLispFunc.Item("read").funcall("(setq pDXF nil)")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
Set obj1 = VLispFunc.Item("read").funcall("(setq pHandle nil)")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
'release the objects or Autocad gets squirrely
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
Exit Function
vbAssocError:
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
MsgBox "Error occurred " & Err.Description
End Function
It might be overkill, but playing with it sure was fun
-
Cool stuff Dave. That's going to see some usage.
-
It might be overkill, but playing with it sure was fun
Heh, heh, man after my own heart.
PS: If I'm not mistaken, some of that code is directly attributable to Mr. Tanzillo, you might consider an appropriate nod in that direction.
(http://www.theswamp.org/screens/mp/nodding.gif)
-
Thanks Bob.
Right MP. Thanks and credit goes to ACADX.com for the VLAX.cls module. That credit used to be a comment in the code. I don't know where it went.