好吧,这对我来说很有用:
- 'SomeCallMeDave
- 'http://www.vbdesign.net/expresso/showthread.php?postid=83887#post83887
- 'Changed pAcadObj As AcadObject to pAcadObj As Object to access imagedef as well
- 'Modified by Jeff Mishler, March 2006, to get the Block table object, not Block_Record table object
- Public Function vbAssoc(pAcadObj, 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
-
- If Left(ThisDrawing.Application.Version, 2) = "16" 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
- If Not TypeOf pAcadObj Is AcadBlock Then
- strHnd = pAcadObj.Handle
- Else
- Dim lispStr As String
- lispStr = "(cdr (assoc 5 (entget (tblobjname " & Chr(34) & "Block" & Chr(34) & Chr(34) & pAcadObj.Name & Chr(34) & "))))"
- Set obj1 = VLispFunc.Item("read").funcall(lispStr)
- strHnd = VLispFunc.Item("eval").funcall(obj1)
- End If
- 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 (no offense RR)
- 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
|