this is what I have so far
Option Explicit
Public Sub CheckDrawingStandards()
' On Error GoTo Err_Control
Dim objBlkRef As AcadBlockReference
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
Dim KillDaFile As Boolean
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.Save
Set FSO = CreateObject("Scripting.FileSystemObject")
strDwgName = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
Set MyFile = FSO.CreateTextFile("H:\DWGAudit\" & 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 vbTab & strLayername & vbTab & strLayerLinetype & vbTab & strLayerColor
KillDaFile = True
End If
Next objLayer
CheckFonts:
MyFile.writeline " "
MyFile.writeline "Non Standard Fonts:"
Set objFont = ThisDrawing.TextStyles.Item("Standard")
objFont.fontFile = "romans.shx"
objFont.Width = 0.85
objFont.Height = 0#
For Each objFont In ThisDrawing.TextStyles
Select Case UCase(objFont.Name)
Case "STANDARD"
Case "*|STANDARD" ' eval if xrefed
Case "TEP"
Case "TEP-TITLE"
Case "TEP-TITLE 3-16"
Case "TEP-TITLE 1-8"
Case Else
MyFile.writeline vbTab & objFont.Name & vbTab & objFont.fontFile
KillDaFile = True
End Select
Next objFont
For Each objFont In ThisDrawing.TextStyles
Select Case UCase(objFont.fontFile)
Case "ROMANS.SHX"
Case "VERDANA.TTF"
Case Else
MyFile.writeline vbTab & objFont.Name & vbTab & objFont.fontFile
KillDaFile = True
End Select
Next objFont
CheckDimStyles:
MyFile.writeline " "
MyFile.writeline "Non Standard Dimension Styles:"
Dim objDimStyle As AcadDimStyle
For Each objDimStyle In ThisDrawing.DimStyles
Select Case UCase(objDimStyle.Name)
Case "STANDARD"
Case "TEP"
Case Else
MyFile.writeline vbTab & objDimStyle.Name
KillDaFile = True
End Select
Next objDimStyle
CheckTitleBlocks:
MyFile.writeline " "
MyFile.writeline "Titleblock and Info block:"
Set objBlkRef = getblock("TEP")
If Not objBlkRef Is Nothing Then
If CheckBlockSpace(objBlkRef) = False Then
MyFile.writeline vbTab & "Titleblock not inserted in PaperSpace"
KillDaFile = True
End If
If CheckBlockProps(objBlkRef) = False Then
MyFile.writeline vbTab & "Titleblock on wrong layer, it should be on ANNO-TITL"
KillDaFile = True
End If
If CheckBlockLocation(objBlkRef) = False Then
MyFile.writeline vbTab & "Titleblock not inserted at 0,0"
KillDaFile = True
End If
End If
Set objBlkRef = getblock("UES")
If Not objBlkRef Is Nothing Then
If CheckBlockSpace(objBlkRef) = False Then
MyFile.writeline vbTab & "Titleblock not inserted in PaperSpace"
KillDaFile = True
End If
If CheckBlockProps(objBlkRef) = False Then
MyFile.writeline vbTab & "Titleblock on wrong layer, it should be on ANNO-TITL"
KillDaFile = True
End If
If CheckBlockLocation(objBlkRef) = False Then
MyFile.writeline vbTab & "Titleblock not inserted at 0,0"
KillDaFile = True
End If
End If
Set objBlkRef = getblock("TITLINFO")
If Not objBlkRef Is Nothing Then
If CheckBlockSpace(objBlkRef) = False Then
MyFile.writeline vbTab & "InfoBlock not inserted in PaperSpace"
KillDaFile = True
End If
If CheckBlockProps(objBlkRef) = False Then
MyFile.writeline vbTab & "InfoBlock on wrong layer, it should be on ANNO-TITL"
KillDaFile = True
End If
If CheckBlockLocation(objBlkRef) = False Then
MyFile.writeline vbTab & "InfoBlock not inserted at 0,0"
KillDaFile = True
End If
End If
Set objBlkRef = getblock("VTITLINFO")
If Not objBlkRef Is Nothing Then
If CheckBlockSpace(objBlkRef) = False Then
MyFile.writeline vbTab & "InfoBlock not inserted in PaperSpace"
KillDaFile = True
End If
If CheckBlockProps(objBlkRef) = False Then
MyFile.writeline vbTab & "InfoBlock on wrong layer, it should be on ANNO-TITL"
KillDaFile = True
End If
If CheckBlockLocation(objBlkRef) = False Then
MyFile.writeline vbTab & "InfoBlock not inserted at 0,0"
KillDaFile = True
End If
End If
Set objBlkRef = getblock("E-ANNO-STKR")
If Not objBlkRef Is Nothing Then
If CheckBlockSpace(objBlkRef) = False Then
MyFile.writeline vbTab & "Project Sticker not inserted in PaperSpace"
KillDaFile = True
End If
If CheckBlockProps(objBlkRef) = False Then
MyFile.writeline vbTab & "Project Sticker on wrong layer, it should be on ANNO-TITL"
KillDaFile = True
End If
End If
MyFile.Close
If KillDaFile = False Then
Kill "H:\DWGAudit\" & strDwgName & ".TXT"
End If
Exit Sub
End Sub
Private Function getblock(strName As String) As AcadBlockReference
Dim vardata(1) As Variant
Dim intType(1) As Integer, objBlkRef As AcadBlockReference
Dim strblockname As String, objSelset As AcadSelectionSet, ABR As AcadBlockReference
ACADSelSet objSelset, "vbdblkrefset"
intType(0) = 0
vardata(0) = "INSERT"
intType(1) = 2
vardata(1) = UCase(strName)
objSelset.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=vardata
For Each ABR In objSelset
Set getblock = ABR
Exit Function
Next
End Function
Public Function ACADSelSet(funcObjSelSet As AcadSelectionSet, funcSelectionSetName As String)
Dim objSelCol As AcadSelectionSets
On Error GoTo Err_Control
Set objSelCol = ThisDrawing.SelectionSets
For Each funcObjSelSet In objSelCol
If funcObjSelSet.Name = funcSelectionSetName Then
funcObjSelSet.Clear
funcObjSelSet.Delete
Exit For
End If
Next
Set funcObjSelSet = objSelCol.Add(funcSelectionSetName)
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case -2145386300
MsgBox "ACAD_Functions.ACADSelSet" & vbCrLf & Err.Number & " - " & Err.Description
Case Else
MsgBox "ACAD_Functions.ACADSelSet" & vbCrLf & Err.Number & " - " & Err.Description
'ACADBugReportFiller "ACAD_Functions.ACADSelSet", Err.Number, Err.Description
End Select
End Function
Private Function CheckBlockLocation(pBlkRef As AcadBlockReference) As Boolean
' Dim objSelset As AcadSelectionSet
' Dim objBlkRef As AcadBlockReference
' Dim vardata(1) As Variant
' Dim intType(1) As Integer
' ACADSelSet objSelset, "vbdblkrefset"
' intType(0) = 0
' vardata(0) = "INSERT"
' intType(1) = 2
' vardata(1) = UCase(strblockname)
' objSelset.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=vardata
' For Each objBlkRef In objSelset
If Not pBlkRef.InsertionPoint(0) = 0 Or Not pBlkRef.InsertionPoint(1) = 0 Then
CheckBlockLocation = False
Exit Function
End If
' Next objBlkRef
Exit_Here:
Exit Function
End Function
Private Function CheckBlockSpace(pBlkRef As AcadBlockReference) As Boolean
CheckBlockSpace = (pBlkRef.OwnerID = ThisDrawing.PaperSpace.ObjectID)
End Function
Private Function CheckBlockProps(pBlkRef As AcadBlockReference) As Boolean
If pBlkRef.Layer = "ANNO-TITL" Then
CheckBlockProps = True
End If
End Function
Private Function CheckName(Layername As String) As Integer
Dim strLayername As String
Open "H:\DWGAudit\layer.txt" For Input As #1
While Not EOF(1)
Line Input #1, strLayername
If UCase(Layername) = UCase(strLayername) Then
Close #1
GoTo Good
End If
Wend
Close #1
CheckName = 1
Exit Function
Good:
CheckName = 0
Exit Function
End Function
