外部参照-在VBA区分“已卸载”和“未找到” 乐筑天下

lambwill 发表于 2006-6-28 08:14:50

外部参照-在VBA区分“已卸载”和“未找到”

你好，这是我在这里的第一篇帖子，所以大家好-很高兴见到你
现在进入正题:
我正在尝试编写一个宏，它将修复我继承的一堆非常混乱的绘图。在很大程度上，这个宏运行得很好，节省了我大量的时间和压力，但是我有一个症结。由于我从另一个位置继承了这些图形，因此我的所有外部参照路径都已断开。当然，这可以通过使用“PROJECTNAME”变量更改缺失外部参照的搜索路径并重新加载所有外部参照来轻松解决，但是有些外部参照已被引用但未被加载，需要保持这种状态。我一直在寻找一种方法来区分未加载的外部参照和路径断开的外部参照(即“未找到”)，但我在任何地方都找不到方法。我的大部分编程经验都来自VBA，所以用这种语言的解决方案是最好的——但是如果需要的话，我有足够的LISP经验来理解它。
预先感谢任何帮助
**** Hidden Message *****

SomeCallMeDave 发表于 2006-6-28 08:41:11

这是我几年前写的东西(从那以后就再也没看过)。所以我不记得它当时的效果如何，也不知道它现在是否还会有效，但它可能会让你开始。
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

lambwill 发表于 2006-6-28 09:19:16

我必须将第15行中的“我”改为“this drawing ”( Set col blocks = Me。Blocks)来让它为我工作，但是我的朋友很可能就是我正在寻找的代码！
非常感谢

SomeCallMeDave 发表于 2006-6-28 09:22:14

不客气希望能帮上忙

lambwill 发表于 2006-6-28 09:27:40

请参见此主题中的此帖子。最好的运气编码一个纯vb等效利用dxf组码71。
PS:欢迎来到沼泽。

SomeCallMeDave 发表于 2006-6-28 10:59:26

我记得那个戴夫。你在一个类似的问题上为我做了那件事。

SomeCallMeDave 发表于 2006-6-28 11:21:33

我不得不说，那个线程正好在我的脑海中。谢天谢地，Dave的代码完全符合要求，所以我现在不会试图理解它而给自己一个疝气。在这种情况下使用LISP有明显的优势吗？

SomeCallMeDave 发表于 2006-6-28 11:28:43

它更漂亮？开玩笑。
正如我所读到的：在vb中，它是演绎的，在lisp中它是确定的。最后，这可能只是学术性的，对你的解决方案没有任何影响。

SomeCallMeDave 发表于 2006-6-28 11:55:07

我同意MP的观点。我发布的代码是基于当时有效的一些未记录的条件，可能会改变，也可能不是对所有情况都有效。这只是一个快速的似乎奏效了。
我猜，位代码的值也可能改变。但是人们希望AutoDesk能够记录它们。

SomeCallMeDave 发表于 2006-6-28 13:41:33

真是度过几个雨天的好方法！！当然比工作好。
这是一个VBA例程，它使用70和71代码进行xref状态。它需要在AutoCAD安装文件夹中重新引用VLisp ActiveX模块（vl16.tlb2004、2005、2006版本。无论如何，在我的计算机上。您可能必须搜索它）
我还没有完全测试它，但它似乎在我所做的测试中起作用。
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

这可能有点过分，但玩它确实很有趣

页: [1] 2

乐筑天下's Archiver

外部参照-在VBA区分“已卸载”和“未找到”