TheSwamp
Code Red => VB(A) => Topic started by: David Hall on July 17, 2008, 06:09:40 PM
-
Off the top of my head, I cant remember how to determine if a block is in MS or PS. Can someone remind me? I thought it had somethinhg to do with OwnerID, but I can t find any code where I have used that, so Im not sure Im on the right track
-
nevermind, Bryco did it before and I just couldn't find it
Function IsPs(oBref As AcadBlockReference) As Boolean
Dim oblock As AcadBlock
Set oblock = ThisDrawing.ObjectIdToObject(oBref.OwnerID)
If Not oblock.Name = "*Model_Space" Then
IsPs = True
End If
End Function
-
A more betterer one perhaps? It demonstrates how to compare numbers (ObjectId's) rather than doing string comparisons:
Function IsPs(pBlkRef As AcadBlockReference) As Boolean
IsPs = (pBlkRef.OwnerID <> ThisDrawing.ModelSpace.ObjectID)
End Function
Cheers,
Glenn.
-
Actually, that should strictly be:
Function IsPs(pBlkRef As AcadBlockReference) As Boolean
IsPs = (pBlkRef.OwnerID = ThisDrawing.PaperSpace.ObjectID)
End Function
-
Glenn, I would think the first one more correct. "ThisDrawing.Paperspace" only refers to the most recently current Layout, so if the block is in any of the other Layouts the second method would still return False.
-
Jeff,
Yeah, that's correct and only if this is being used in conjunction with a selectionset gathered from the user for instance. If you're processing inserts that are nested, all bets are off and neither of these would be correct anyway.
It shows the intent though :)
-
Thanks Glenn, I like that much better.!
-
No probs Duh.
-
Assuming
Set objBlkRef = getblock("UES")
returns a block named UES, how can I check to see if it was returned? I tried
If Not objBlkRef = Nothing
which failed badly
-
Assuming
Set objBlkRef = getblock("UES")
returns a block named UES, how can I check to see if it was returned? I tried
If Not objBlkRef = Nothing
which failed badly
I believe it should be:
If objBlkRef Is Nothing Then
-
Correct.
-
I found it easier to make the getblock function a boolean.
If not getblock("UES") then goto InsertBlock
set b=thisdrawing.blocks("UES")
-
OK, I think I know what I need to do, but was wondering if there was a better way. The code below checks what fonts are in the dwg, including fonts that came from Xrefs. The quoted text below is in my text file "audit" of the dwg, and you can see the 3D-TTL-B| was consistently found to be wrong. So I tried using a wildcard *| which also failed (I expected it to, but was hoping). So I "think" I should use Instr() to check for the "|" character, and use the next char to the end of string for my check. Is there a better way or am I on the right track?
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
Non Standard Fonts:
3D-TTL-B|Standard Romans.shx
3D-TTL-B|TEP Romans.shx
3D-TTL-B|arial ARIALBD.TTF
3D-TTL-B|UES impact.TTF
3D-TTL-B|TEP-TITLE verdana.TTF
3D-TTL-B|arial ARIALBD.TTF
3D-TTL-B|UES impact.TTF
-
BTW, Seant, you were spot on and it fixed my problem perfectly
-
Huh? We've gone from 'what space am I' to an 'audit' scenario....what exactly are you trying to do in the first place Duh?
-
Sorry Glenn, I was just posting in the same thread to avoid creating a new one. Maybe I should create a new thread.
Anyway, what space am i in was part of my dwg audit I am trying to put together to make sure consultants put the titleblock in paperspace.
-
If oTStyle.Name Like "*|*" Then
Don't you have to open the xref to fix the font? (It's read only)
-
... to make sure consultants put the titleblock in paperspace.
Do you supply the insultants with a titleblock to use or do they use their own and it must be the same name as yours or something else...?
-
Bryco's on the money for dependent symbol name checks as far as VBA goes...
-
... to make sure consultants put the titleblock in paperspace.
Do you supply the insultants with a titleblock to use or do they use their own and it must be the same name as yours or something else...?
:-D :-D :-D :lmao: :lmao: :lmao:
we supply them the block, but we cant guarentee they put it in PS. I gave them a template w/ it in PS, and I still got dwgs back where they had wblocked it out and inserted in MS
-
This sounds like something the company I'm working for at the moment does and it's called a CAD QA or CADQA as the program is called.
I assume your 'audit' program is checking the insultant's supplied drgs with your company standards as specified by the contract.
If this assumption is correct, can you outline what your 'QA' process is please? I might be able to give you another spin on this...
-
ACtually, regardless of my assumption above, give the outline of what your 'QA' program is trying to accomplish...
-
If oTStyle.Name Like "*|*" Then
Don't you have to open the xref to fix the font? (It's read only)
yes, but that is their problem. The idea is TEP-Romans.shx is correct, if its in an xref, its still correct. I needed a way to pick up the xref name and ignore as long as the TEP and Romans part were correct
-
Glenn, I would greatly appreciate that, as I'm flying blind at the moment.
-
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
-
Duh, can you give me an outline, in your words, as to what you're trying to achieve not the code please...
-
this (http://www.theswamp.org/index.php?topic=23994.0 this) is what I am trying to accomplish
- Layers- Names/Color/Linetype
- Text Styles
- Titleblock/info block properties-correct layer, insertion point, etc.
- Image props-correct layer, insertion point, etc
- Dimension Style settings
- Use of Mtext vs Dtext, Null text strings
- XREF props-correct layer, insertion point, relative pathing, etc
- Everything By Layer
- Revisions using double digits( 01, not 1)
this is what I have so far
-
Ok, after reading that other thread you linked (which I missed as I don't venture into the VBA forum much anymore) I suggest this become a project and it moves to .NET as I know you've been experimenting there, with C# if memory serves.
I forsee that I'm going to have a need of this type of thing in future as well and I have some ideas about how to accomplish this (possibly using a plugin for the cad stds checker) or a totally standalone command. Thoughts anyone?
-
BTW, your last post is what I expected you were wanting to check and you're definately not alone on this one.
-
I hope it goes to C# as changing unwanted textstyles is something I couldn't do 100% in vba, it's on the list to do in c#
-
I would love to make this a C# project. How soon can everyone start? :lmao: I think I will be the slow one in the group as you are correct, I am trying to move to .Net, its just been a whole lot of baby steps making small progress
-
I guess what I'm trying to say is I can help, and if you guys steer me in the right direction, I can try to do as much as possible, just be patient with me
-
Do you guys "fix" it or flag it for the insultant to fix (that is still cracking me up)
-
Ok, post a new thread in the .NET group and we'll see if we can make this a semi-professional project...coding standards and everything...I'm quite sure there will be some interest other than me....Dan, Bryco, Kerry etc.
-
I am asking b/c it has been stated here that anything that doesn't pass the cad qa/qc is sent back to the insultant to fix on their own nickel
-
Where I am currently at, we 'advise' as to the pass or failure of the 'QA' to the relevant project mismanager and then he can make the call as to whether to fix in-house or throw the digital rubbish back in the insultant's digital lap.
Personally, if the insultant's contract says 'thou shalt produce drgs to this, our standard' then the insultant must comply...