OK, merging the ideas of gile, Chuck G. and Kean Walmsley I've come up with this:
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Runtime
Imports System.IO
Namespace Purger
Public Class PurgeFiles
Public Sub PurgeDatabase(ByVal db As Database)
'Dim idCount As Integer = 0
Dim tr As Transaction = db.TransactionManager.StartTransaction()
Using tr
Dim locked As New List(Of LayerTableRecord)()
Dim lt As LayerTable = DirectCast(tr.GetObject(db.LayerTableId, OpenMode.ForRead), LayerTable)
For Each layerId As ObjectId In lt
Dim ltr As LayerTableRecord = DirectCast(tr.GetObject(layerId, OpenMode.ForRead), LayerTableRecord)
If ltr.IsLocked = True Then
ltr.UpgradeOpen()
ltr.IsLocked = False
locked.Add(ltr)
End If
Next
Dim bt As BlockTable = DirectCast(tr.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
For Each btrId As ObjectId In bt
Dim btr As BlockTableRecord = DirectCast(tr.GetObject(btrId, OpenMode.ForRead), BlockTableRecord)
If Not btr.IsLayout Then
Continue For
End If
For Each id As ObjectId In btr
Dim crv As Curve = TryCast(tr.GetObject(id, OpenMode.ForRead), Curve)
If crv IsNot Nothing Then
If crv.GetDistanceAtParameter(crv.EndParam) = 0.0 Then
crv.UpgradeOpen()
crv.[Erase]()
End If
Continue For
End If
Dim txt As DBText = TryCast(tr.GetObject(id, OpenMode.ForRead), DBText)
If txt IsNot Nothing Then
If txt.TextString.Trim() = String.Empty Then
txt.UpgradeOpen()
txt.[Erase]()
End If
Continue For
End If
Dim mTxt As MText = TryCast(tr.GetObject(id, OpenMode.ForRead), MText)
If mTxt IsNot Nothing AndAlso GetTextString(mTxt).Trim() = String.Empty Then
mTxt.UpgradeOpen()
mTxt.[Erase]()
End If
Next
Next
For Each ltr As LayerTableRecord In locked
ltr.IsLocked = True
Next
' Create the list of objects to "purge"
Dim idsToPurge As New ObjectIdCollection()
' Add all the Registered Application names
Dim rat As RegAppTable = DirectCast(tr.GetObject(db.RegAppTableId, OpenMode.ForRead), RegAppTable)
Dim ltt As LinetypeTable = DirectCast(tr.GetObject(db.LinetypeTableId, OpenMode.ForRead), LinetypeTable)
Dim blt As BlockTable = DirectCast(tr.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
Dim lat As LayerTable = DirectCast(tr.GetObject(db.LayerTableId, OpenMode.ForRead), LayerTable)
Dim dst As DimStyleTable = DirectCast(tr.GetObject(db.DimStyleTableId, OpenMode.ForRead), DimStyleTable)
Dim tst As TextStyleTable = DirectCast(tr.GetObject(db.TextStyleTableId, OpenMode.ForRead), TextStyleTable)
Dim mat As DBDictionary = DirectCast(tr.GetObject(db.MaterialDictionaryId, OpenMode.ForRead), DBDictionary)
Dim mlst As DBDictionary = DirectCast(tr.GetObject(db.MLeaderStyleDictionaryId, OpenMode.ForRead), DBDictionary)
Dim mlnt As DBDictionary = DirectCast(tr.GetObject(db.MLStyleDictionaryId, OpenMode.ForRead), DBDictionary)
Dim tabt As DBDictionary = DirectCast(tr.GetObject(db.TableStyleDictionaryId, OpenMode.ForRead), DBDictionary)
Dim dicID As DBDictionaryEntry
Dim OId As ObjectId
For Each OId In rat
If OId.IsValid Then
idsToPurge.Add(OId)
End If
Next
For Each OId In ltt
If OId.IsValid Then
idsToPurge.Add(OId)
End If
Next
For Each OId In blt
If OId.IsValid Then
idsToPurge.Add(OId)
End If
Next
For Each OId In lat
If OId.IsValid Then
idsToPurge.Add(OId)
End If
Next
For Each OId In dst
If OId.IsValid Then
idsToPurge.Add(OId)
End If
Next
For Each OId In tst
If OId.IsValid Then
idsToPurge.Add(OId)
End If
Next
For Each dicID In mat
Dim key As String = dicID.Key
If (key <> "ByBlock") AndAlso (key <> "ByLayer") AndAlso (key <> "Global") Then
idsToPurge.Add(dicID.Value)
End If
Next
For Each dicID In mlst
If dicID.Value.IsValid Then
idsToPurge.Add(dicID.Value)
End If
Next
For Each dicID In mlnt
If dicID.Value.IsValid Then
idsToPurge.Add(dicID.Value)
End If
Next
For Each dicID In tabt
If dicID.Value.IsValid Then
idsToPurge.Add(dicID.Value)
End If
Next
' Call the Purge function to filter the list
db.Purge(idsToPurge)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
' Erase each of the objects we've been
' allowed to
Dim errorobj As String = "Nothing"
Try
For Each id As ObjectId In idsToPurge
Dim obj As DBObject = tr.GetObject(id, OpenMode.ForWrite)
errorobj = obj.ToString
obj.Erase()
Next
Catch ex As Exception
MsgBox(errorobj.ToString, MsgBoxStyle.Critical)
End Try
tr.Commit()
End Using
'Return idCount
End Sub
Private Function GetTextString(ByVal mtxt As MText) As String
Dim result As String = mtxt.Contents
While result.Contains(MText.BlockBegin)
result = result.Substring(0, result.IndexOf(MText.BlockBegin)) & result.Substring(result.IndexOf(MText.BlockEnd) + 1)
End While
Return result
End Function
'Public Sub RunAudit(ByVal db As Database)
' Dim tr As Transaction = db.TransactionManager.StartTransaction()
' Using tr
' Dim DBobjectList As AuditInfo
' DBobjectList.
' For Each dbObj As Object In DBobjectList
' db.Audit(dbObj)
' Next
' End Using
' tr.Commit()
'End Sub
End Class
End Namespace
So far it mostly works. Two things:
First it doesn't purge the Registered Apps like is should. Even though stepping through the process it acts like it does.
Second I had to ignore the Material "GLOBAL" because it errors that it can't be erased. Even though it can be purged using the purge command.
Please comment on my grossly bad coding and thoughts on where to go from here.
Thanks
Chris