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.