通过autoCAD-vba画管道单线图

    工作中需要画大量单线图，如图1。为了方便快捷，自己编了以下代码方便画图。有些文字重叠的需要手动调整。

图1：

以下为操作规程：

1、环境：win8.1, AutoCAD 2014

2、根据管线走向编制list.txt文件内容
    m,10,10,10               - 起始坐标
    f,ZQ2-YJxx-D114-abdc-1   - 向前画单线，并标注焊口号
    f2,ZQ2-YJxx-D114-abdc-1  - 向前画2倍长度单线，并标注焊口号
    f2                       - 向前画2倍长度单线
    b                        - 向后
    l                        - 向左
    r                        - 向右
    u                        - 向上

    d                        - 向下

3、操作：
    a. 管理 - 加载应用程序，选择drawLine.dvb加载
    b. 运行VBA宏
    c. 选择drawLine.dvb!ThisDrawing.main运行

    d. 输入list.txt文件路径

4、drawLine.dvb代码：

Sub main()
    ' ==========================
    ' 功能：根据list.txt内容绘制单选图
    ' 版本：v1.0
    ' 作者：[email protected]
    ' 时间：2018-04-16
    '
    ' - list.txt内容说明
    '     m: 起始坐标
    '     u:向上  d:向下
    '         f:前
    '     l:左  十  r:右
    '         b:后
    '     字母后跟线段长度的倍数，默认1
    '
    ' - 例如:
    '     m,100,100,100
    '     f,ZQ2-YJxx-D114-abdc-1
    '     r,ZQ2-YJxx-D114-abdc-5w
    '     f2
    '     l,ZQ2-YJxx-D114-abdc-6
    '
    ' ==========================

    ' 设置字体文件
    Dim textStyle1 As AcadTextStyle
    Set textStyle1 = ThisDrawing.ActiveTextStyle
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    newFontFile = Application.Path & "\Fonts\txt.shx"
    textStyle1.Height = 10
    If fso.FileExists(newFontFile) Then
        textStyle1.fontFile = newFontFile
    End If
    
    ' 画图
    ret_loc = "0,0,0"
    listFilePath = InputBox("请输入《list.txt》文件路径")
    listFile = listFilePath & "\list.txt"
    
    If fso.FileExists(listFile) Then
        Open listFile For Input As #1
        Do While Not EOF(1)
            Line Input #1, rLine
            If Mid(rLine, 1, 1) <> "'" Then
                If LCase(Mid(rLine, 1, 1)) = "m" Then
                    ret_loc = Mid(rLine, 3, Len(rLine) - 2)
                Else
                    arr_xy = Split(ret_loc, ",")
                    ret_loc = fn_drawGroup(rLine, CDbl(arr_xy(0)), CDbl(arr_xy(1)), CDbl(arr_xy(2)))
                End If
            End If
        Loop
        Close #1
    End If
    
    ZoomAll
    
End Sub


Function fn_drawGroup(strstr, x0, y0, z0)
    
    iLen = 80         ' 画线长度
    iSize = 10        ' 字体高度
    fRotate = False   ' 字体是否旋转
    
    arrStr = Split(strstr, ",")
    strFirstSec = CStr(Trim(arrStr(0)))
    strDirection = Mid(strFirstSec, 1, 1)
    
    If LCase(strDirection) = "m" Then
        fn_drawGroup = Mid(strstr, 3, Len(strstr) - 2)
    End If
    
    If Len(strFirstSec) > 1 Then iLen = iLen * CInt(Mid(strFirstSec, 2, 1))
    x1 = x0: y1 = y0: z1 = z0
    Select Case LCase(strDirection)
        Case "f"                     ' front
            y1 = y0 + iLen
        Case "b"                     ' back
            y1 = y0 - iLen
        Case "l"                     ' left
            x1 = x0 - iLen
            fRotate = True
        Case "r"                     ' right
            x1 = x0 + iLen
            fRotate = True
        Case "u"                     ' up
            z1 = z0 + iLen
        Case "d"                     ' down
            z1 = z0 - iLen
    End Select
    
    ' 画线
    Call DrawPolyline(x0, y0, z0, x1, y1, z1)
    
    If UBound(arrStr) = 1 Then
        ' 画中间点
        Call DrawCircle((x0 + x1) / 2, (y0 + y1) / 2, (z0 + z1) / 2)
        ' 写文字
        Call DrawText(Trim(arrStr(1)), (x0 + x1) / 2, (y0 + y1) / 2, (z0 + z1) / 2, iSize, fRotate)
    End If
    fn_drawGroup = x1 & "," & y1 & "," & z1
    
End Function


Sub DrawPolyline(x0, y0, z0, x1, y1, z1)
    Dim objPL As Acad3DPolyline
    Dim xyz(5) As Double
    xyz(0) = x0: xyz(1) = y0: xyz(2) = z0
    xyz(3) = x1: xyz(4) = y1: xyz(5) = z1
    Set objPL = ThisDrawing.ModelSpace.Add3DPoly(xyz)
End Sub


Sub DrawCircle(x0, y0, z0)
    Dim r As Double
    Dim xyz(2) As Double
    Dim xyz0(2) As Double
    Dim outerLoop(0 To 0) As AcadEntity
    Dim hatchObj As AcadHatch
    
    r = 5   ' 圆半径
    xyz(0) = x0: xyz(1) = y0: xyz(2) = z0
    xyz0(0) = x0: xyz0(1) = y0: xyz0(2) = 0
    
    PatternName = "SOLID"
    PatternType = 0
    bAssociativity = True
    
    Set outerLoop(0) = ThisDrawing.Application.ActiveDocument.ModelSpace.AddCircle(xyz, r)    ' 画圆
    Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, PatternName, bAssociativity)  ' 填充
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Move xyz0, xyz
    hatchObj.Evaluate
    ThisDrawing.Regen True
End Sub


Sub DrawText(strText, x0, y0, z0, iSize, fRotate)
    ' iSize: 字体尺寸
    ' fRotate: 是否旋转
    Dim textObj As AcadText
    Dim xyz(2) As Double
    Dim xyz1(2) As Double
    Dim xyz2(2) As Double
    xyz(0) = x0: xyz(1) = y0: xyz(2) = z0
    xyz1(0) = x0 - 210: xyz1(1) = y0: xyz1(2) = z0
    xyz2(0) = x0: xyz2(1) = y0 - 10: xyz2(2) = z0
    Set textObj = ThisDrawing.Application.ActiveDocument.ModelSpace.AddText(strText, xyz, iSize)
    If fRotate = True Then
       DblAngle = ThisDrawing.Utility.AngleToReal(-90, acDegrees)
       textObj.Rotation = DblAngle
       textObj.Move xyz, xyz2
    Else
       textObj.Move xyz, xyz1
    End If
End Sub