TheSwamp
Code Red => VB(A) => Topic started by: Matersammichman on October 10, 2006, 11:46:24 AM
-
I'm looking for code that I can use to list all of the Images contained in a dwg file. Suggestions?
-
Suggestion #1 :wink: :-)
What is a good way to get started on writing code to list images in a dwg.?
-
Look for the 'ACAD_IMAGE_DICT' (dictionary) in the drawing, and then step through it for all the images.
-
Is there what you looking for?
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'~
-
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?
-
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
-
Thanks for all the input, but I've decided to just use a Diesel expression in Fields. It's much simpler.
-
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'~
-
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.
-
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.
-
Bryco,
Could I obtain a copy of that LISP routine...pleeeeze?
-
I think Bryco's solution is VBA not lisp
-
VBA would work even better!
-
Matersammichman, I think this covers it.
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
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
-
??? It choked on vbAssoc. :lol:
-
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.
'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
-
Now it chokes in the sub at (sset) in the entry below.
Set SS = sset(0, "Image")
ideas...?
-
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