通过autoCAD-vba画管道单线图 [ v1.5 ]

更新版本v1.5：

1、支持空间方位，如lfu，表示左前上方

2、支持单引号注释，单行或语句后方

3、自动保存上次使用路径

Sub main()
    ' ==========================
    ' 功能：根据list.txt内容绘制单选图
    ' 版本：v1.5
    ' 作者：[email protected] #bin.xu
    ' 时间：2018-05-24
    '
    ' 0、字母说明：
    '    m: 起始坐标
    '    u: 向上
    '    d: 向下
    '             f:前(北)
    '                |
    '    l:左(西)  ──├── r:右(东)
    '                |
    '             b:后(南)
    '
    ' 1、字母后跟线段长度的整数倍（<10），缺省时为1个线段长度
    ' 2、[v1.5] 支持空间方位，如lfu，表示左前上方
    ' 3、[v1.5] 支持单引号注释，单行或语句后方
    ' 4、[v1.5] 自动保存上次使用路径
    '
    ' - 例如:
    '     m,100,100,100
    '     f,ZQ2-YJxx-D114-abdc-1
    '     r,ZQ2-YJxx-D114-abdc-5w
    '     f2
    '     l,ZQ2-YJxx-D114-abdc-6
    '     lfu,ZQ2-YJxx-D114-abdc-7
    '
    ' ==========================

    ' 设置字体文件
    Dim textStyle1 As AcadTextStyle
    Set textStyle1 = ThisDrawing.ActiveTextStyle
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sh = CreateObject("WScript.Shell")
    
    newFontFile = Application.Path & "\Fonts\txt.shx"
    textStyle1.Height = 10
    If fso.FileExists(newFontFile) Then
        textStyle1.fontFile = newFontFile
    End If
    
    listFilePath = ""
    ' 获取~setting.tmp文件
    strTmpPath = sh.ExpandEnvironmentStrings("%TMP%")
    strSetFileName = strTmpPath & "\~setting.tmp"
    If fso.FileExists(strSetFileName) Then
        Open strSetFileName For Input As #1
        Do While Not EOF(1)
            Line Input #1, rLine
            listFilePath = CStr(rLine)
        Loop
        Close #1
    End If
    
    ' 获取list.txt路径
    ret_loc = "0,0,0"
    listFilePath = InputBox("请输入《list.txt》文件路径", "输入", listFilePath)
    listFile = Replace(listFilePath, """", "") & "\list.txt"
    
    ' 画图
    ret_loc = "0,0,0"
    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) <> "'" And CStr(rLine) <> "" Then
                If InStr(rLine, "'") <> 0 Then rLine = Trim(Mid(rLine, 1, InStr(rLine, "'") - 1))
                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
    
    ' 西南等轴侧
    ThisDrawing.Application.ActiveDocument.SendCommand "-view" & vbCr & "swiso" & vbCr
    ZoomAll
    
    ' 路径写入~setting.tmp文件
    If fso.FileExists(listFile) Then
        Open strSetFileName For Output As #1
            Write #1, Replace(listFilePath, """", "")
        Close #1
    End If
    
End Sub


Function fn_drawGroup(strstr, x0, y0, z0)
    
    iLen = 80         ' 画线长度
    iSize = 10        ' 字体高度
    fRotate = False   ' 字体是否旋转
    
    ' 获取方位
    arrStr = Split(strstr, ",")
    strFirstSec = CStr(Trim(arrStr(0)))
    If IsNumeric(Mid(StrReverse(strFirstSec), 1, 1)) = True Then
        strDirection = LCase(Mid(strFirstSec, 1, Len(strFirstSec) - 1))
    Else
        strDirection = LCase(strFirstSec)
    End If
    
    ' 获取倍数
    If Len(strFirstSec) > 1 And IsNumeric(Mid(StrReverse(strFirstSec), 1, 1)) = True Then
        iLen = iLen * CInt(Mid(StrReverse(strFirstSec), 1, 1))
    End If
    
    ' 转换坐标
    x1 = x0: y1 = y0: z1 = z0
    If InStr(strDirection, "f") <> 0 Then y1 = y0 + iLen
    If InStr(strDirection, "b") <> 0 Then y1 = y0 - iLen
    If InStr(strDirection, "l") <> 0 Then x1 = x0 - iLen: fRotate = True
    If InStr(strDirection, "r") <> 0 Then x1 = x0 + iLen: fRotate = True
    If InStr(strDirection, "u") <> 0 Then z1 = z0 + iLen
    If InStr(strDirection, "d") <> 0 Then z1 = z0 - iLen
    
    ' 画线
    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)
    ' 上色
    Dim color As New AcadAcCmColor
    'Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19")
    color.SetRGB 0, 255, 255
    objPL.TrueColor = color
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