Topic: Code request

[Bryco]

The good thing about functions are that they save you writing, but it is a bit hard to post them all.
I'm hoping SomeCallMeDave will put this in functions sometime, it's a beauty.

Code: [Select]

'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

[Matersammichman]

Now it chokes in the sub at (sset) in the entry below.

Set SS = sset(0, "Image")

ideas...?

[Bryco]

Code: [Select]

Function IsNestedImage(sName As String) As Boolean
    On Error GoTo Err_Control

    Dim Ent As AcadEntity
    Dim oBlock As AcadBlock
    Dim oBlocks As AcadBlocks
    Dim strBlock As String
    Set oBlocks = ThisDrawing.Blocks
    For Each oBlock In oBlocks
        strBlock = oBlock.Name
        If oBlock.IsLayout Then GoTo NextBlock
        If InStr(1, strBlock, "|") <> 0 Then GoTo NextBlock
        If oBlock.Name = "_ARCHTICK" Then GoTo NextBlock
        If oBlock.IsXRef Then GoTo NextBlock
        'If oBlock.Name = "" Then
           ' DeleteEmptyBlock
           ' GoTo NextBlock
       ' End If
        For Each Ent In oBlock
            If TypeOf Ent Is AcadRasterImage Then
                If Not Ent.ObjectName = "AcDbWipeout" Then
                    If Ent.Name = sName Then
                        'Debug.Print Ent.Name, oBlock.Name
                        IsNestedImage = True
                        Exit Function
                        Exit For
                    End If
                End If
            End If
        Next Ent
NextBlock:
    Next oBlock
Exit_Here:
    Exit Function
Err_Control:
    Select Case Err.Number
    'Add your Case selections here
        Case Else
        Debug.Print Err.Number, Err.Description
        MsgBox Err.Description
        Err.Clear
        Resume Exit_Here
    End Select
End Function