Topic: Code request

[Matersammichman]

I'm looking for code that I can use to list all of the Images contained in a dwg file. Suggestions?

[Maverick®]

Suggestion #1    

What is a good way to get started on writing code to list images in a dwg.?

[T.Willey]

Look for the 'ACAD_IMAGE_DICT' (dictionary) in the drawing, and then step through it for all the images.

[Fatty]

Is there what you looking for?

Code: [Select]

Option Explicit

Sub GetImages()

Dim objDict As AcadDictionary
Set objDict = ThisDrawing.Dictionaries("ACAD_IMAGE_DICT")

If objDict.Count < 0 Then
MsgBox "No images definitions in this database."
Else
MsgBox "There are " & objDict.Count & "images definitions"

Dim oSset As AcadSelectionSet
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim dxfcode As Variant
Dim dxfdata As Variant
ftype(0) = 0: fdata(0) = "IMAGE"
dxfcode = ftype
dxfdata = fdata

For Each oSset In ThisDrawing.SelectionSets
If oSset.Name = "$IMAGESET$" Then
Exit For
End If
Next oSset

If oSset Is Nothing Then
Set oSset = ThisDrawing.SelectionSets.Add("$IMAGESET$")
Else
oSset.Clear
End If

oSset.Select acSelectionSetAll, , , dxfcode, dxfdata

If oSset.Count > 0 Then

Dim oEntity As AcadEntity
Dim objImage As AcadRasterImage
Dim tmpArr(1) As Variant
Dim imageColl As New Collection
For Each oEntity In oSset
Set objImage = oEntity
tmpArr(0) = objImage.Name
Debug.Print tmpArr(0)
tmpArr(1) = objImage.ImageFile
Debug.Print tmpArr(1)
imageColl.Add tmpArr
Erase tmpArr
Next
Else
MsgBox "No images inserted."
End If
End If

oSset.Delete
Set oSset = Nothing
End Sub
Fatty

~'J'~

[Matersammichman]

Thanks for the coding help.

I tried your code and it choked on:

Set objDict = ThisDrawing.Dictionaries("ACAD_IMAGE_DICT")

Why is it doing this?

[Bryco]

 Try something like below, a dictionary is a bit funky as it can also be an xrecord so typeof is a good way to get it straight 

 Dim oDics As AcadDictionaries
    Dim oDic As AcadDictionary
    Dim oD
   
    Set oDics = ThisDrawing.Dictionaries
    For Each oD In oDics
        If TypeOf oD Is AcadDictionary Then
            If oD.Name = "ACAD_IMAGE_DICT" Then
                Set oDic = oD

[Matersammichman]

Thanks for all the input, but I've decided to just use a Diesel expression in Fields. It's much simpler.

[Fatty]

Try something like below, a dictionary is a bit funky as it can also be an xrecord so typeof is a good way to get it straight 

 Dim oDics As AcadDictionaries
    Dim oDic As AcadDictionary
    Dim oD
   
    Set oDics = ThisDrawing.Dictionaries
    For Each oD In oDics
        If TypeOf oD Is AcadDictionary Then
            If oD.Name = "ACAD_IMAGE_DICT" Then
                Set oDic = oD

Hi, Bryco

Nice one, as always
You beat me, thanks

Fatty

~'J'~

[T.Willey]

The problem may be that the dictionary isn't in the drawing, so images are in the drawing.  I know this is a problem in lisp, I don't know/use VBA that is why I didn't post any code, just an idea.  In lisp you would catch the error to see if it is there.

[Bryco]

I use it in a purge sub that lists all the unloaded images with the choice to delete them. I find it very handy and the vba does it fine.

[Matersammichman]

Bryco,
Could I obtain a copy of that LISP routine...pleeeeze?

[David Hall]

I think Bryco's solution is VBA not lisp

[Matersammichman]

VBA would work even better!

[Bryco]

Matersammichman, I think this covers it.

Code: [Select]

Private Sub DeleteUnloadedImages()
    On Error GoTo Err_Control

    Dim oDics As AcadDictionaries
    Dim oDic As AcadDictionary
    Dim oD, Imagedef
    Dim i As Integer, sImageName As String
    Dim oImage As AcadRasterImage
    Dim SS As AcadSelectionSet
    Dim Answer As Integer, strPrompt As String
    Dim isThere As Boolean
    Dim obj(0) As AcadEntity
   
    Set oDics = ThisDrawing.Dictionaries
    For Each oD In oDics
        If TypeOf oD Is AcadDictionary Then
            If oD.Name = "ACAD_IMAGE_DICT" Then
                Set oDic = oD
                Set SS = sset(0, "Image")
                For Each Imagedef In oDic
                    sImageName = oDic.GetName(Imagedef)
                     Debug.Print sImageName, vbAssoc(Imagedef, 280)
                    If vbAssoc(Imagedef, 280) = 0 Then
                        strPrompt = "The image: """ & sImageName & """ is unloaded" & vbCrLf & "Choose Yes to delete"
                        Answer = MsgBox(strPrompt, vbYesNo, "Unloaded Image Files")
                        If Answer = vbYes Then
                            Imagedef.Delete
                        End If
                       
                    Else
                        isThere = False
                        If SS.count > 0 Then
                            For Each oImage In SS

                                  If oImage.Name = sImageName Then
                                      isThere = True
                                      Exit For
                                  End If
Nextimage:
                            Next oImage
                            If Not isThere Then
                            Dim bl As Boolean
                            bl = IsNestedImage(sImageName)
                             Debug.Print sImageName, bl
                                If Not IsNestedImage(sImageName) Then
                                    strPrompt = "The image: """ & sImageName _
                                            & """ is unreferenced" & vbCrLf & "Choose Yes to delete"
                                    Answer = MsgBox(strPrompt, vbYesNo, "Unreferenced Image Files")
                                    If Answer = vbYes Then
                                        Imagedef.Delete
                                    End If
                                End If
                            End If
                        End If
                        'SS.Delete
                    End If
                Next Imagedef
                SS.Delete
                Exit For
            End If
        End If
    Next oD
   
Exit_Here:
    Exit Sub
Err_Control:
    Select Case Err.Number
        Case -2145386476  'Key not found
            Set obj(0) = oImage
            SS.RemoveItems obj
            oImage.Delete
            Err.Clear
            GoTo Nextimage
    'Add your Case selections here
        Case Else
        'MsgBox Err.Description
        Debug.Print Err.Number, Err.Description
        Err.Clear
        Resume Exit_Here
    End Select
End Sub
and a function

Code: [Select]

Public Function sset(FilterType, FilterData As Variant, Optional ssName As String = "SS") As AcadSelectionSet
   
    Dim oSSets As AcadSelectionSets
    Set oSSets = ThisDrawing.SelectionSets
    For Each sset In oSSets
        If sset.Name = ssName Then
            sset.Delete
            Exit For
        End If
    Next
    Dim FType() As Integer
    Dim FData() As Variant
    Dim i As Integer
    If IsArray(FilterType) = False Then
        If IsArray(FilterData) = False Then
            ReDim FType(0)
            ReDim FData(0)
            FType(0) = FilterType
            FData(0) = FilterData
        Else
            Exit Function
        End If
    Else
        If UBound(FilterType) <> UBound(FilterData) Then
            Exit Function 'They must be pairs
        End If
       
        ReDim FType(UBound(FilterType))
        ReDim FData(UBound(FilterType))
        For i = 0 To UBound(FilterType)
            FType(i) = FilterType(i)
            FData(i) = FilterData(i)
        Next
    End If
   
    Set sset = ThisDrawing.SelectionSets.Add(ssName)
    sset.Select 5, FilterType:=FType, FilterData:=FData
    'To use this function for single filter
    'Set SS = SSet(0, "insert")
    'For multiple filter
    'Set SS = SSet(array(0,2),array("insert",oBlock.name)) 'must be pairs
End Function

[Matersammichman]

It choked on vbAssoc.

[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