Drawing pipeline one-line diagram through autoCAD-vba

    A large number of one-line diagrams need to be drawn in the work, as shown in Figure 1. For convenience and speed, I compiled the following code to facilitate drawing. Some overlapping texts need to be adjusted manually.

figure 1:

The following are the operating procedures:

1. Environment: win8.1, AutoCAD 2014

2. According to the pipeline direction, prepare the contents of the list.txt file
    m, 10, 10, 10 - starting coordinates
    f, ZQ2-YJxx-D114-abdc-1 - draw a single line forward, and mark the welding slogan
    f2, ZQ2-YJxx-D114 -abdc-1 - Draw a single line 2 times forward, and mark the welding slogan
    f2 - Draw a single line 2 times forward
    b - Back
    l - Left
    r - Right
    u - Up

    d - down

3. Operation:
    a. Manage - Load the application, select drawLine.dvb to load
    b. Run the VBA macro
    c. Select drawLine.dvb!ThisDrawing.main to run

    d. Enter the list.txt file path

4. drawLine.dvb code:

Sub main()
    ' ==========================
    'Function: draw a radio map according to the content of list.txt
    ' version: v1.0
    ' Author: [email protected]
    ' Time: 2018-04-16
    '
    ' - list.txt content description
    ' m: starting coordinate
    ' u: up d: down
    ' f: front
    ' l: left ten r: right
    ' b: after
    ' letter followed by a multiple of the length of the line segment, default 1
    '
    ' - E.g:
    '     m,100,100,100
    '     f,ZQ2-YJxx-D114-abdc-1
    '     r,ZQ2-YJxx-D114-abdc-5w
    '     f2
    '     l,ZQ2-YJxx-D114-abdc-6
    '
    ' ==========================

    ' set font file
    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
    
    ' draw
    ret_loc = "0,0,0"
    listFilePath = InputBox("Please enter the file path of "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' draw line length
    iSize = 10 ' font height
    fRotate = False ' whether the font is rotated
    
    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
    
    ' draw the line
    Call DrawPolyline(x0, y0, z0, x1, y1, z1)
    
    If UBound(arrStr) = 1 Then
        ' draw the middle point
        Call DrawCircle((x0 + x1) / 2, (y0 + y1) / 2, (z0 + z1) / 2)
        ' write text
        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' circle radius
    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: font size
    ' fRotate: whether to rotate
    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