TheSwamp

Code Red => VB(A) => Topic started by: Matersammichman on August 04, 2006, 01:21:21 PM

Title: Text question
Post by: Matersammichman on August 04, 2006, 01:21:21 PM

How can you use vba to make underlined text?

Title: Re: Text question
Post by: Jeff_M on August 04, 2006, 02:06:11 PM

Like so:

Code: [Select]

Dim InsPt(2) As Double
Dim strTxt As String

strTxt = "How about %%uunderline%%u?"
ThisDrawing.ModelSpace.AddText strTxt, InsPt, 0.2


Title: Re: Text question
Post by: Matersammichman on August 04, 2006, 03:15:29 PM

Hmmm...
I'm with ya, but I'd like to be able to put in the text from a text box input , and not have to put in "%%U" every time...
more ideas?

Title: Re: Text question
Post by: Jeff_M on August 04, 2006, 03:36:31 PM

Huh? You mean like this?

Code: [Select]

Dim InsPt(2) As Double
Dim strTxt As String

strTxt = "%%u" & TextBox1.Value & "%%u"
ThisDrawing.ModelSpace.AddText strTxt, InsPt, 0.2


Title: Re: Text question
Post by: Matersammichman on August 04, 2006, 03:52:20 PM

Yes, thank you.

Title: Re: Text question
Post by: Matersammichman on October 31, 2006, 03:43:45 PM

Okay, let's carry it a step further-
How would you create DOUBLE underlined text?

Title: Re: Text question
Post by: David Hall on October 31, 2006, 03:44:49 PM

Quote from: Matersammichman on October 31, 2006, 03:43:45 PM

Okay, let's carry it a step further-
How would you create DOUBLE underlined text?

how would you do it in regular acad?

Title: Re: Text question
Post by: Matersammichman on October 31, 2006, 03:46:50 PM

unfortunately...draw another line under the text manually.

Title: Re: Text question
Post by: Greg B on October 31, 2006, 03:54:34 PM

I thought there was a font properties that allowed you to have double underline.

Title: Re: Text question
Post by: Keith™ on October 31, 2006, 04:25:15 PM

Quote from: Greg B on October 31, 2006, 03:54:34 PM

I thought there was a font properties that allowed you to have double underline.

not in AutoCAD

Title: Re: Text question
Post by: David Hall on October 31, 2006, 04:41:35 PM

Quote from: Matersammichman on October 31, 2006, 03:46:50 PM

unfortunately...draw another line under the text manually.

given that, you could use the text ins pt, and calc the text length, then offset (or draw) a second line below the first.

Title: Re: Text question
Post by: Murphy on November 01, 2006, 05:00:39 AM

I actually have this done in VBA as our titles at work are text with double underlines drawn in.
I will post the code once I get to work.

Title: Re: Text question
Post by: Murphy on November 01, 2006, 06:34:11 AM

Obviously you can go and customize to your hearts content.
They are plines so that the width can be made to what you need.

Code: [Select]

Public Sub TitleLine()
 Dim objPick As AcadEntity
 Dim varPnt As Variant
 Dim strPrmt As String
 Dim objUtil As AcadUtility
 Dim fPt As Variant
 Dim rpt As Variant
 Dim txtIns As Variant
 Dim lin As AcadLine
 Dim plin As AcadPolyline
 Dim plinpts(0 To 5) As Double
 Dim linst(0 To 2) As Double
 Dim linend(0 To 2) As Double
 Dim fx As Variant
 Dim rx As Variant
 Dim midx As Variant
 Dim modscl As Integer
On Error GoTo ErrHandler
 strPrmt = vbCr & "Pick Title: "
 Set objUtil = ThisDrawing.Utility
DoOver:
 objUtil.GetEntity objPick, varPnt, strPrmt
 If TypeOf objPick Is AcadText Then
    objPick.GetBoundingBox fPt, rpt
    txtIns = objPick.InsertionPoint
    If rpt(0) - fPt(0) < 1.75 Then
        midx = fPt(0) + (0.5 * (rpt(0) - fPt(0)))
        fx = midx - 0.875
        rx = midx + 0.875
    Else
        fx = fPt(0)
        rx = rpt(0)
    End If
    If ThisDrawing.ActiveSpace = acPaperSpace Then
        plinpts(0) = fx
        plinpts(1) = txtIns(1) - 0.0625
        plinpts(2) = 0
        plinpts(3) = rx
        plinpts(4) = txtIns(1) - 0.0625
        plinpts(5) = 0
        Set plin = ThisDrawing.PaperSpace.AddPolyline(plinpts)
        plin.ConstantWidth = 0.03125
        plin.layer = "0"
        plin.color = acGreen
        linst(0) = fx
        linst(1) = plinpts(1) - 0.0625
        linst(2) = 0
        linend(0) = rx
        linend(1) = linst(1)
        linend(2) = 0
        Set lin = ThisDrawing.PaperSpace.AddLine(linst, linend)
        lin.layer = "0"
        lin.color = acGreen
    Else
        modscl = objPick.height / 0.175
        plinpts(0) = fx
        plinpts(1) = txtIns(1) - (0.0625 * modscl)
        plinpts(2) = 0
        plinpts(3) = rx
        plinpts(4) = txtIns(1) - (0.0625 * modscl)
        plinpts(5) = 0
        Set plin = ThisDrawing.ModelSpace.AddPolyline(plinpts)
        plin.ConstantWidth = (0.03125 * modscl)
        plin.layer = "0"
        plin.color = acGreen
        linst(0) = fx
        linst(1) = plinpts(1) - (0.0625 * modscl)
        linst(2) = 0
        linend(0) = rx
        linend(1) = linst(1)
        linend(2) = 0
        Set lin = ThisDrawing.ModelSpace.AddLine(linst, linend)
        lin.layer = "0"
        lin.color = acGreen
    End If
 End If
 'GoTo DoOver
ExitNow:
 Exit Sub
ErrHandler:
 Select Case Err.Number
    Case -2147352567
        Err.Clear
        GoTo ExitNow
    Case Else
        Err.Clear
        GoTo ExitNow
End Select
End Sub

Title: Re: Text question
Post by: Matersammichman on November 03, 2006, 07:57:46 AM

Great code Murphy!
Thanks!

Title: Re: Text question
Post by: Murphy on November 06, 2006, 05:11:26 AM

Not a problem. That's what makes this place so great.
Why redo what someone has already done?