Impeding progress...

What is holding these things up? Well in the publishing world (AutoCAD Publish that is), a user kept getting a "Job Already In Progress" dialog popping up. He is one of the few users here who use Publish since we have an in house solution already for plotting but nonetheless we needed to solve it. A few searches hinted at a solution and it turned out to be that within the OPTIONS >> PLOT AND PUBLISH tab, the Enable Background Processing for PUBLISHING was set to ON. He switched it to OFF (unchecked) and he no longer has impeded progress. It is about time to live in the here and now. May the Lord Bless.

Too much support

Well, Sometimes you just get too much support. How's that? Recently I began getting a pop up dialog that prompted me that the drawing I was opening had Mechanical objects that were saved to a version that made them incompatible. That is good info but I was using vanilla AutoCAD and I had never seen this come up before. It appeared from the command line to run a _amconsistencycheck command. I tried looking it up but to no avail. To make a long story short, I had added a new support path in my Options that pointed to the ACADM folder. Once this path was removed, the command did not come up automatically.

Rabbit out of the hat.

A few weeks ago, we made the rabbit disappear, this week we will make it reappear (making the invisible visible again). The tricky part with invisible things is how do you get a hold of them in the first place. Well, you have to "grab them" by one of their properties and then "feed this" to other sub.

Private Sub Set_InvisibleObjSS(ByRef acSS1 As AcadSelectionSet)
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim acSS As AcadSelectionSet
Dim dPt1(0 To 2) As Double
Dim dPt2(0 To 2) As Double
Dim iCode(0) As Integer
Dim vVal(0) As Variant
'''''''''''''''''''''''''''''''''''''''
iCode(0) = 60 'visibilty pair
vVal(0) = 1 '1=invisible, 0=visible
Set acSS = ClearSS("INVIS")

acSS.Select acSelectionSetAll, dPt1, dPt2, iCode, vVal 'ALL OBJECTS
Set acSS1 = acSS

End Sub

Public Function Set_SsInvisibilityOn(ByRef acSS As AcadSelectionSet)
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim acSS As AcadSelectionSet
Dim acObj As AcadObject
Dim acLyr As AcadLayer
Dim acLyrs As AcadLayers
Dim sCurrLyr As String
'''''''''''''''''''''''''''''''''''''''

Set acLyrs = ThisDrawing.Layers
'------------------------------------------------------------------------------
'Cycle through all objects
'------------------------------------------------------------------------------
For Each acObj In acSS
If acObj.Visible = False Then
sCurrLyr = acObj.layer
Set acLyr = acLyrs.Item(sCurrLyr)
'Check for locked layer, and unlock it if it is
If acLyr.Lock Then
acLyr.Lock = False 'Unlock the Layer.
acObj.Visible = True 'Display the invisible item
acLyr.Lock = True 'Re-lock the Layer.
Else
acObj.Visible = True
End If
End If
acObj.Update
Next acObj

End Function

The king's clothes are missing.

Have you ever wanted to take off the "clothes" of Mtext. Well, here you are. A Mtext unformatter. It is a nice little routine, that I built from a post on the Autodesk forum site. I apologize to the author but I do not have their name. I tweaked it just a little but the main idea is still there.

Public Function MText_Unformat(ByVal sTxt As String) As String
'------------------------------------------------------------------------------
'Remove formatting strings
'
'Value Examples:
' \A Sets the alignment value; valid values: 0, 1, 2 (bottom, center, top)
' \Cvalue; Changes to the specified color
' \Hvalue; Changes to the specified text height
' \Hvaluex; Changes to multiple of mtext object's property
' \L...\l Turns underline on and off
' \O...\o Turns overline on and off
' \P Ends paragraph/Carriage return
' \Qangle; Changes obliquing angle
' \S...^...; Stacks the subsequent text at the \ or ^ symbol
' \Tvalue; Adjusts the space between characters
' \Wvalue; Changes width factor to produce wide text
' \~ Inserts a nonbreaking space
' \\ Inserts a backslash
' \{...\} Inserts an opening and closing brace
' \File name; Changes to the specified font file
'
'------------------------------------------------------------------------------
Dim P1 As Integer
Dim P2 As Integer
Dim P3 As Integer
Dim iStart As Integer
Dim sComp As String
Dim sReplace As String
Dim sLittle As String
'''''''''''''''''''''''''''''''''''''''
Debug.Print sTxt
'------------------------------------------------------------------------------
'Remove alignment codes
'------------------------------------------------------------------------------
Select Case Left(sTxt, 4)
Case "\A0;", "\A1;", "\A2;"
sTxt = Mid(sTxt, P1 + 5)
End Select
iStart = 1
'------------------------------------------------------------------------------
'Replace octal code values with strings
'------------------------------------------------------------------------------
Do
P1 = InStr(sTxt, "%%")
If P1 = 0 Then
Exit Do
Else
Select Case Mid(sTxt, P1 + 2, 1)
Case "P"
sTxt = Replace(sTxt, "%%P", "+or-")
Case "D"
sTxt = Replace(sTxt, "%%D", " deg")
End Select
End If
Loop

Do
P1 = InStr(iStart, sTxt, "\", vbTextCompare)
If P1 = 0 Then Exit Do
sComp = Mid(sTxt, P1, 2)
Select Case sComp
Case "\p"
P2 = InStr(1, sTxt, ";")
sTxt = Mid(sTxt, P2 + 1)
Case "\A", "\C", "\f", "\F", "\H", "\Q", "\T", "\W"
P2 = InStr(P1 + 2, sTxt, ";", vbTextCompare)
P3 = InStr(P1 + 2, sTxt, sComp, vbTextCompare)
If P3 = 0 Then
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P2 + 1)
End If
Do While P3 > 0
P2 = InStr(P3, sTxt, ";", vbTextCompare)
sTxt = Left(sTxt, P3 - 1) & Mid(sTxt, P2 + 1)
'Debug.Print sTxt, sComp
P3 = InStr(1, sTxt, sComp, vbTextCompare)
Loop
'sTxt = Left(sTxt, P3 - 1) & mid(sTxt, P3 + 1)
Case "\L", "\O"
sLittle = LCase(sComp)
P2 = InStr(P1 + 2, sTxt, sLittle, vbTextCompare)
If P2 = 0 Then
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P1 + 2)
Else
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P1 + 2, P2 - (P1 + 2)) & Mid(sTxt, P2 + 2)
End If
Case "\S"
P2 = InStr(P1 + 2, sTxt, ";", vbTextCompare)
P3 = InStr(P1 + 2, sTxt, "/", vbTextCompare)
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, sTxt, "#", vbTextCompare)
End If
If P3 = 0 Or P3 > P2 Then
P3 = InStr(P1 + 2, sTxt, "^", vbTextCompare)
End If
sTxt = Left(sTxt, P1 - 1) & Mid(sTxt, P1 + 2, P3 - (P1 + 2)) _
& "/" & Mid(sTxt, P3 + 1, (P2) - (P3 + 1)) & Mid(sTxt, P2 + 1)

Case "\U" 'Replace symbols with text
sLittle = Mid(sTxt, P1 + 3, 4)
Debug.Print sLittle
Select Case sLittle
Case "2248"
sReplace = "ALMOST EQUAL"
Case "2220"
sReplace = "ANGLE"
Case "2104"
sReplace = "CENTER LINE"
Case "0394"
sReplace = "DELTA"
Case "0278"
sReplace = "ELECTRIC PHASE"
Case "E101"
sReplace = "FLOW LINE"
Case "2261"
sReplace = "IDENTITY"
Case "E200"
sReplace = "INITIAL LENGTH"
Case "E102"
sReplace = "MONUMENT LINE"
Case "2260"
sReplace = "NOT EQUAL"
Case "2126"
sReplace = "OHM"
Case "03A9"
sReplace = "OMEGA"
Case "214A"
sReplace = "PROPERTY LINE"
Case "2082"
sReplace = "SUBSCRIPT2"
Case "00B2"
sReplace = "SQUARED"
Case "00B3"
sReplace = "CUBED"
End Select
sTxt = Replace(sTxt, "\U+" & sLittle, sReplace)
Case "\~"
sTxt = Replace(sTxt, "\~", " ")
Case "\\"
iStart = P1 + 2
sTxt = Replace(sTxt, "\\", "\")
GoTo Selectagain
Case "\P"
iStart = P1 + 1
GoTo Selectagain
Case Else
Exit Do
End Select
Selectagain:
Loop
'------------------------------------------------------------------------------
'Replace \P with vbCrLf
'------------------------------------------------------------------------------
Do
P1 = InStr(1, sTxt, "\P", vbTextCompare)
If P1 = 0 Then
Exit Do
Else
sTxt = Left(sTxt, P1 - 1) & vbCrLf & Mid(sTxt, P1 + 2)
End If
Loop
For iStart = 0 To 1
If iStart = 0 Then
sComp = "}"
Else
sComp = "{"
End If
P2 = InStr(1, sTxt, sComp)

Do While P2 > 0
sTxt = Left(sTxt, P2 - 1) & Mid(sTxt, P2 + 1)
P2 = InStr(1, sTxt, sComp)
Loop
Next iStart

MText_Unformat = sTxt

End Function

The one constant is change..

Here are some constants I created that I use quite often. I made them global so they would be available to any routine I might write (just place them in a module that you can remember). You can create your own constants also or change these to your liking (you know what they say about constants..)

Global Const radian_30 = 0.52359877
Global Const radian_45 = 0.78539816
Global Const radian_60 = 1.04719755
Global Const radian_90 = 1.57079632
Global Const radian_120 = 2.0943951
Global Const radian_135 = 2.35619449
Global Const radian_150 = 2.61799387
Global Const radian_180 = 3.141592654
Global Const radian_210 = 3.665191429
Global Const PI = 3.14159265358979

For my next trick...

OK. I spoke about it before, so now I will show how to make the entities disappear. No peeking... Oh, enough of that. Feed this SUB your selection set and tada. Presto change-o, it has disappeared. Stay tuned.

Public Sub MakeObjSsInvisible(ByRef acSS As AcadSelectionSet)
'------------------------------------------------------------------------------
'
'Arguments: AutoCAD selection set
'Returns: None
'Caveats: Must unlock the layer they reside on first or it does not work
'------------------------------------------------------------------------------
Dim sCurrLyr As String
Dim objLayer As Object ' AcadLayer
Dim objLayers As Object 'AcadLayers
Dim acEnt As AcadObject
'''''''''''''''''''''''''''''''''''''''
For Each acEnt In acSS
sCurrLyr = acEnt.layer
Set objLayer = objLayers.Item(sCurrLyr)
If objLayer.Lock Then
objLayer.Lock = False 'unlock it
acEnt.Visible = False
objLayer.Lock = True 'lock it back up
Else
acEnt.Visible = False
End If
acEnt.Update
Next

If Not acSS Is Nothing Then
acSS.Delete
End If

End Sub

On the code again...

I decided (when I remember) to post a code snippet each week. Seems like so many are learning and wanting to learn customization that I would give back a little of what I have gained. This week is a simple little example of getting info from your user by way of an input box. Its fairly quick and does not require you to create a new form or code it. Works nice with text input. Enjoy.

Private Function GetStartingItemNo() As String
Dim sPrompt As String
Dim sTitle As String
Dim sDefault As String
'''''''''''''''''''''''''''''''''''''''
sPrompt = "Input Starting itemNumber"
sTitle = "Item Numbering"
sDefault = "1"
GetStartingItemNo = InputBox(sPrompt, sTitle, sDefault)

End Function

5 Minutes Of Fame

I recently had some of my code posted on Cadalyst. I am posting it here for those of you who may need to copy attributes from one block to another block. We do this semi-often with various title blocks from customers and it comes in handy for "copying" information around. Enjoy.

Public Sub UserCopyAttsFromBlkToAnotherBlk()
'------------------------------------------------------------------------------
'user selects block and then selects attributed block to match to
'
'------------------------------------------------------------------------------
Dim vAtts As Variant
Dim vAtts2 As Variant
Dim sPrompt As String
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler

sPrompt = "Select Source Attributed Block: "
vAtts = UserGetBlockWithAtts(sPrompt).GetAttributes

sPrompt = "Select Destination Attributed Block: "
vAtts2 = UserGetBlockWithAtts(sPrompt).GetAttributes

Call CopySameAttsFromBlkToBlk(vAtts, vAtts2)

ErrHandler:
Select Case Err.Number
Case 0
Case Else
Err.Clear
End Select
End Sub

Public Function UserGetBlockWithAtts(Optional sPrompt As String = _
"Select Attributed Block: ") As AcadBlockReference
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim acObj As Object
Dim vPickPt As Variant
Dim sAtt As String
'''''''''''''''''''''''''''''''''''''''
On Error GoTo NOT_ENTITY

TRY_AGAIN:
ThisDrawing.Utility.GetEntity acObj, vPickPt, sPrompt
If acObj.ObjectName <> "AcDbBlockReference" Then
GoTo NOT_ENTITY
End If

If acObj.HasAttributes Then
Set UserGetBlockWithAtts = acObj
Else
MsgBox "This Block has no Attributes"
End If
Exit Function

NOT_ENTITY:
'If you click on space or do not select an entity, this error will be generated
If MsgBox("You have not selected a block with attributes.", vbOKCancel) = vbOK Then
Resume TRY_AGAIN
End If
End Function


Public Sub CopySameAttsFromBlkToBlk(ByVal vAtts1 As Variant, _
ByRef vAtts2 As Variant)
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim l As Long
Dim m As Long
'''''''''''''''''''''''''''''''''''''''
For m = LBound(vAtts1) To UBound(vAtts1)
For l = LBound(vAtts2) To UBound(vAtts2)
If vAtts1(m).TagString = vAtts2(l).TagString Then
vAtts2(l).TextString = vAtts1(m).TextString
End If
Next l
Next m
End Sub

Snappy Tabby

Catchy title (don't you think? .. anyway). Just a quick reminder (one of our users asked the other day), if you use multiple osnap types but it seems AutoCad has this uncanny way of picking the one you do not want first, you can toggle through your osnaps with the TAB key. Like I said, Snappy Tabby.

Hold the presses...

Printing that is. A user's plot dialog in AutoCAD took at least a minute to appear. I thought it could be a page setup issue, but he was set to None, so no issue there. I thought about it, maybe his printers. Took a quick look and what do you know, he had printers that were obsolete and/or unreachable from his computer. We deleted them and poof, the dialog is fast again. I have heard the same issue can appear with old drivers and certain printers (update if necessary). Let the presses roll!

My UG is stuck

Okay, my first UG NX post. Well, we have UG NX4 and TeamCenter and we open our UG files through TeamCenter. We have startup scripts but when I got to a certain point the Command window just hangs. It is the process UG_remote that is the culprit. I kill the process and then all is well. Not stuck. The cause of all this was a failed startup because all of our network licenses were used up. Good to know for next time.

Unknown but not forgotten

What next! Today I was going along as usual and then my "CH" (PROPERTIES) command disappeared. "What in the world.." I get an "Command: _properties Unknown command "PROPERTIES" Not good (I think to myself). I go to Control Panel and do a "Repair Registry" on my AutoCAD install. Nope, no change. I then do a "Repair Install". Nope. Getting a little worried here. I do a reinstallation. Still nothing. Oh no I think to myself. Finally I find the solution. It is the DEMANDLOAD variable. I never think about it, so it never occurred to me. I type it in, it is set to 0, so I change it to 2 and "wahlah", I am known again. It's good not to be forgotten.

When is a font not a font..

Hey, my drawing looks weird. I have text that uses ISOCP.SHX but now it looks "too wide". I check the style, but it is set correctly. What the... I check for the font file.. okay. What I finally do is reboot (an old IT favorite). Well what do you know, the style is back (get it..back in style) Okay, till next time. Also see 2010.08.02 for update

reOrdination

What I meant to say was changing your ordinates (dimension that is). I was looking how to change an ordinate dimension's origin in VB but I found that there is no property for that. Rats. I came up with a side track to do it and I figured I would post it if you needed to reordinate also.

Private Sub SetOrdinateZeroPoint(ByVal sHandle As String, ByVal vPt As Variant)
'------------------------------------------------------------------------------
'Changes an ordinate dims origin
'Arguments: sHandle - handle of dim entity
' vPt - variant point of new origin
'Example: Call SetOrdinateZeroPoint(acEnt.Handle, vPt1)
'------------------------------------------------------------------------------
ThisDrawing.SendCommand "(setq dimEnt (entget (handent """ & sHandle & """)))" & vbCr
ThisDrawing.SendCommand "(entmod (subst '(10 " & vPt(0) & " " & vPt(1) & " 0.0) (assoc 10 dimEnt) dimEnt))" & vbCr
End Sub

Exploding Mechanical Objects

I know that those who work with Mechanical can appreciate the Mechanical objects that it creates and how it makes life easier. But what if another client wants the drawings and does not want these proxy entities in the drawing. The method usually suggested is to tell them to get the object enabler or to manually explode those objects (which Mechanical does fairly well). I have created a macro to explode the Mechanical objects to their AutoCAD equivalents and I wanted to know if anyone had any interest on a posting of a compiled version. Let me know if there is any interest. Thanks.

Notes are not up to scale.

So your mechanical leader and notes are behaving badly and not scaling to the viewport scale. Bad notes, bad... You either need the notes whisperer or set a couple of variables to neuter these issues. AMSYMSCALE sets symbols (ie Notes) back on track and AMRESCALE gets your existing notes to behave. Whew.. good notes, good.

Isn't that special.

Or should I say "that isn't special". The special characters in the dimensioning mode show incorrectly. The diameter symbol for instance looks like some weird text. Well this is a Window Font issue. Look for the AMGDT*.ttf fonts in the Windows\Font folder. If they are not there, copy them from a working computer or do a repair install of AutoCAD Mechanical and you should get them back. Congratulations, you are special again.