I couldn't figure out how to get all my standards into the checker, so I started writing my own
Option Explicit
Public Sub GetInfoLayers()
Dim FSO, MyFile As Variant
Dim objLayer As AcadLayer, objFont As AcadTextStyle
Dim strDwgName As String
Dim strLayername As String, strLayerLinetype As String, strLayerColor As String
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
Set FSO = CreateObject("Scripting.FileSystemObject")
strDwgName = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
Set MyFile = FSO.CreateTextFile("C:\" & strDwgName & ".TXT", True)
MyFile.WriteLine "Drawing: " & strDwgName & ", located at: " & ThisDrawing.Path & "\"
CheckLayers:
MyFile.WriteLine " "
MyFile.WriteLine "Non Standard Layers: "
For Each objLayer In ThisDrawing.Layers
strLayername = objLayer.Name
strLayerLinetype = objLayer.Linetype
strLayerColor = objLayer.color
If CheckName(strLayername) = 1 Then
MyFile.WriteLine strLayername & vbTab & strLayerLinetype & vbTab & strLayerColor
End If
Next objLayer
CheckFonts:
MyFile.WriteLine " "
MyFile.WriteLine "Non Standard Fonts:"
For Each objFont In ThisDrawing.TextStyles
Select Case UCase(objFont.fontFile)
Case "ROMANS.SHX"
Case "VERDANA.TTF"
Case Else
MyFile.WriteLine objFont.Name
End Select
Next objFont
CheckTitleBlocks:
CheckImages:
MyFile.WriteLine " "
Dim objRasterImage As AcadRasterImage
' For Each objRasterImage In ThisDrawing.ModelSpace
' If Not objRasterImage.Layer = "ANNO-SCAN" Then
' MyFile.WriteLine "Image: " & objRasterImage.Name & " wrong layer, on layer " & objRasterImage.Layer
' End If
' Next
MyFile.Close
End Sub
Private Function CheckName(LayerName As String) As Integer
Dim FSO, MyLayerFile As Variant
Dim strLayername As String
' Set FSO = CreateObject("Scripting.FileSystemObject")
' 'Set MyLayerFile = FSO.OpenTextFile("c:\layer.txt", ForReading, False, TristateFalse)
Open "c:\layer.txt" For Input As #1 ' txt file is list of good layers to check against
While Not EOF(1)
Line Input #1, strLayername
If LayerName = strLayername Then
Close #1
GoTo Good
End If
Wend
Close #1
CheckName = 1
Exit Function
Good:
CheckName = 0
Exit Function
End Function
This is how far I have gotten so far today, NO ERROR checking, so use at your own risk