社区 › VB › 文本问题

Matersammichman 发表于 2006-10-31 16:41:35

鉴于此，您可以使用文本ins pt，并计算文本长度，然后在第一行下面偏移(或绘制)第二行。

Murph 发表于 2006-11-1 05:00:39

实际上，我在VBA中完成了这项工作，因为我们工作的标题是带有双下划线的文本
我一开始工作就会发布代码。

Matersammichman 发表于 2006-11-1 06:34:11

显然，您可以根据自己的内心进行自定义内容。
它们是铺线，因此宽度可以根据您的需要。
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

Murph 发表于 2006-11-3 07:57:46

伟大的代码墨菲！
谢谢！

Matersammichman 发表于 2006-11-6 05:11:26

没问题。这就是这个地方如此伟大的原因。
为什么要重做某人已经做过的事情？

查看完整版本: 文本问题