Get in (a)lign....

With text that is. Here is a text alignment snippet I wrote to align some text with a balloon leader (in our industry). It aligns selected text with along two selected points (could be along a line or anything else). Enjoy and get back in (a)lign.

Public Sub AlignSingleLineTextAlongTwoPoints()
'------------------------------------------------------------------------------
'
'
'------------------------------------------------------------------------------
Dim acTxt1 As AcadEntity
Dim vPt1 As Variant
Dim vPt2 As Variant
Dim dScl As Double
Dim dScl1 As Double
Dim dScl2 As Double
Dim dAng As Double
'''''''''''''''''''''''''''''''''''''''
On Error GoTo ErrHandler 'for escape key

Const d45 = 0.7853982 ' 45 degrees in RAD
Const d285 = 1.3089969 ' about 75 degrees in RAD
'''''''''''''''''''''''''''''''''''''''
ThisDrawing.Utility.GetEntity acTxt1, vPt1, "Select Text: "
dScl = acTxt1.height / 3#
dScl1 = dScl * 1.414
dScl2 = dScl * 4.123
'------------------------------------------------------------------------------
vPt1 = ThisDrawing.Utility.GetPoint(, "Select First Point: ")
vPt2 = ThisDrawing.Utility.GetPoint(, "Select Second Point: ")
dAng = ThisDrawing.Utility.AngleFromXAxis(vPt1, vPt2)
'------------------------------------------------------------------------------
'Set the alignment or else the insertion point cannot be overridden below
'REV 2007.12.21
'------------------------------------------------------------------------------
acTxt1.Alignment = acAlignmentLeft
'------------------------------------------------------------------------------
'Set the text insertion point
'------------------------------------------------------------------------------
acTxt1.InsertionPoint = ThisDrawing.Utility.PolarPoint(vPt1, dAng + d45, dScl1)
'------------------------------------------------------------------------------
'Set the text angle
'------------------------------------------------------------------------------
acTxt1.Rotation = dAng

Exit Sub

ErrHandler:
Select Case Err.Number
Case 0
Case -2147352567 'Escape hit
Err.Clear
Case Else
Err.Clear
End Select

End Sub

Are you color blind?

AutoCAD has two basic types of printing styles. Color dependent and style dependent. If you are on the original Color based printing and want to convert your current drawing to this style. Try this little ditty.

Public Function ConvertToCtb()
Const sRet As String = """"
Dim sCmd As String
Dim sPstyle As String
'''''''''''''''''''''''''''''''''''''''
sPstyle = ThisDrawing.GetVariable("PSTYLEMODE")

If sPstyle = "0" Then
sCmd = "(command " & sRet & "convertpstyles" & sRet & " " & ")" & vbCr
ThisDrawing.SendCommand sCmd
End If
End Function

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

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.

Ejection Button.

Eject all your unused baggage. A long time ago I wrote a purge routine that would purge all nested items. I am reposting to help you "lighten the load"

(defun pp_PurgeAllReport (/ test tpurgd purgd total)
(command "_.LAYER" "M" "0" "")
(setq tpurgd 0)
(setq purgd 2)
(while (>= purgd 2)
(progn (setq purgd 0)
(cond
(t
(setvar "cmdecho" 0)
(command "_.purge" "_all" "*")
(while (not (zerop (getvar "cmdactive")))
(command "_y")
(setq purgd (1+ purgd))
(setq tpurgd (1+ tpurgd))
)
)
)
(prompt "\nPurging nested items!")
(princ "\n")
(setq tpurgd (1- tpurgd))
)
)
(setq total (cons tpurgd '(items purged)))
(princ total)
(princ)
)

How to set the standard

In AutoCAD Mechanical, standards are the... well standards by which other things are measured. We base everything off the ISO standard so that we are all on the same "page" so to speak. Most of our customers live by this standard, so it becomes even more important to adhere to their "gold standard" (hint hint ... final payment). Anyway, we generally use a template to start drawings with our standard in place. We have had times where a rogue user or an outside drawing made its way into the mix, so I came up with a little macro to "set the standard". After setting a reference to the SymBBAuto library, use the following to get the standard you always wanted.


Private Sub SetMeStdToIso()
'------------------------------------------------------------------------------
'SetMeStdToIso:
'------------------------------------------------------------------------------
On Error Resume Next
Dim mcadSymBb As McadSymbolBBMgr
Dim mcadStdMgr As McadStandardMgr
Dim mcadStd As McadStandard
'--------------------------------------
Set mcadSymBb = ThisDrawing.Application.GetInterfaceObject("SymBBAuto.McadSymbolBBMgr")
Set mcadStdMgr = mcadSymBb.StandardMgr

mcadStdMgr.CurrentStandardName = "ISO"
If mcadStdMgr.StandardCount > 1 Then
For Each mcadStd In mcadStdMgr.Standards
If mcadStd.name <> "ISO" Then 'Or mcadStd.Name <> "DIN" Then
mcadStd.Delete
End If
Next mcadStd
End If
End Sub

Now for my next trick...

How to make the invisible disappear. Why bother you say. What I found out recently is, what I can't see can hurt me. We convert our files to our customers formats once we have completed their jobs. We convert our layer/linetype structure to their layer/linetype structure. I have created macros to do that for us and they work pretty well. Recently these macros would take an inordinate amount of time to work or even crashing AutoCAD after processing a single drawing for an hour or so. What's happening? The macro would purge the drawings and process all blocks to redefine their "innards". I would see blocks flash on that were not in the drawing. Hmmmm... I thought about it. They are either referenced by something in the drawing and can't be purged or.... they were invisible. AutoCAD now has the power to make things invisible (if you did not know). So, I pulled up a trusty macro I built from some other posts and then like magic, the drawing went from 22 mb to 5 mb and converting layers took 10 seconds. Wow. I am posting this gem in case you need some "magic" also.


Public Sub DeleteInvisibleEnts()
'------------------------------------------------------------------------------
'DeleteInvisibleEnts: Makes all objects in an AutoCAD drawing visible.
'
'------------------------------------------------------------------------------
Dim acSs As AcadSelectionSet
Dim dPt1(0 To 2) As Double
Dim dPt2(0 To 2) As Double
Dim acObj As AcadObject
Dim acLyr As AcadLayer
Dim acLyrs As AcadLayers
Dim sCurrLyr As String
Dim iCode(0) As Integer
Dim vVal(0) As Variant
'''''''''''''''''''''''''''''''''''''''

Set acLyrs = ThisDrawing.Layers
iCode(0) = 60 'visibilty pair
vVal(0) = 1 '1=invisible, 0=visible

Set acSs = ThisDrawing.SelectionSets.Add("INVIS")
acSs.Select acSelectionSetAll, dPt1, dPt2, iCode, vVal 'ALL OBJECTS
'------------------------------------------------------------------------------
'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
'------------------------------------------------------------------------------
'If you stop here, all invisible items are now visible
'------------------------------------------------------------------------------
Call DeleteAllObjsFromSelSet(acSs) 'A macro to cycle thru and delete the items
ThisDrawing.PurgeAll
If Not acSs Is Nothing Then
acSs.Delete
End If

End Sub