更新版本v1.6：
1、[v1.6] 单行NumPos=f, 设置编号显示在圆点的哪个方位，取值：f,b,l,r（前,后,左,右）其中一个
作用范围：直到下一个NumPos赋值
2、[v1.6] 编号前加f=，设置编号显示在圆点的哪个方位，
取值：f,b,l,r（前,后,左,右）其中一个
作用范围：当前语句
优先级：高于NumPos
例：
'list.txt m,100,100,100 NumPos=f r,ZQ3-YJ01-N1-D76-3.4-1 r,ZQ3-YJ01-N1-D114-3.4-84W r,ZQ3-YJ01-N1-D114-3.4-83W f,f=ZQ3-YJ01-N1-D114-3.4-C+24Z r b,ZQ3-YJ01-N1-D114-3.4-82W r,r=ZQ3-YJ01-N1-D114-3.4-81W
图：
Sub main()
' ==========================
' 功能：根据list.txt内容绘制单选图
' 版本：v1.6
' 作者：[email protected] #bin.xu
' 时间：2018-05-27
'
' 0、字母说明：
' m: 起始坐标
' u: 向上
' d: 向下
' f:前(北)
' |
' l:左(西) ──├── r:右(东)
' |
' b:后(南)
'
' 1、功能说明：
' 1.1、字母后跟线段长度的整数倍（<10），缺省时为1个线段长度
' 1.2、[v1.5] 支持空间方位，如lfu，表示左前上方
' 1.3、[v1.5] 支持单引号注释，单行或语句后方
' 1.4、[v1.5] 自动保存上次使用路径
' 1.5、[v1.6] 单行NumPos=f, 设置编号显示在圆点的哪个方位，
' 取值：f,b,l,r（前,后,左,右）其中一个
' 作用范围：直到下一个NumPos赋值, 左前右对齐
' 1.6、[v1.6] 编号前加f=，设置编号显示在圆点的哪个方位，
' 取值：f,b,l,r（前,后,左,右）其中一个
' 作用范围：当前语句，
' 优先级：高于NumPos
'
' 2、例:
' m,100,100,100 ' 起始坐标
' f,ZQ2-YJxx-D114-abdc-1 ' 向前画1个单位长度线段，
' ' 并标注焊口为ZQ2-YJxx-D114-abdc-1
' r,ZQ2-YJxx-D114-abdc-5w
' f2 ' 向前画2个单位长度线段
' l,ZQ2-YJxx-D114-abdc-6
' lfu,ZQ2-YJxx-D114-abdc-7 ' 左前上方画线
' f,f=ZQ3-YJ01-N1-D114-3.4-77Z ' 编号在圆点的前方标注
' NumPos=l ' 之后的编号在圆点左侧标注
'
' ==========================
' 设置字体文件
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路径
listFilePath = InputBox("请输入《list.txt》文件路径", "输入", listFilePath)
listFile = Replace(listFilePath, """", "") & "\list.txt"
' 画图
ret_loc = "0,0,0"
strNumPos = "f"
If fso.FileExists(listFile) Then
Open listFile For Input As #1
Do While Not EOF(1)
Line Input #1, rLine
rLine = Trim(rLine)
If Mid(rLine, 1, 1) <> "'" And CStr(rLine) <> "" Then
If InStr(rLine, "'") <> 0 Then
rLine = Trim(Mid(rLine, 1, InStr(rLine, "'") - 1))
End If
If LCase(Mid(rLine, 1, 1)) = "m" Then
ret_loc = Mid(rLine, 3, Len(rLine) - 2)
ElseIf LCase(Mid(rLine, 1, 6)) = "numpos" Then
strNumPos = Mid(StrReverse(rLine), 1, 1)
Else
arr_xy = Split(ret_loc, ",")
ret_loc = fn_drawGroup(rLine, strNumPos, 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
ThisDrawing.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, strNumPos, x0, y0, z0)
iLen = 80 ' 画线长度
iSize = 10 ' 字体高度
tmpNumPos = strNumPos
' 获取方位
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
If InStr(strDirection, "r") <> 0 Then x1 = x0 + iLen
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
strText = Replace(Trim(arrStr(1)), " ", "")
' 画中间点
Call DrawCircle((x0 + x1) / 2, (y0 + y1) / 2, (z0 + z1) / 2)
' 获取strNumPos
If InStr(arrStr(1), "=") <> 0 Then
tmpNumPos = Mid(strText, 1, 1)
strText = Mid(strText, 3)
End If
' 写文字
Call DrawText(strText, (x0 + x1) / 2, (y0 + y1) / 2, (z0 + z1) / 2, iSize, tmpNumPos)
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.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, strNumPos)
' iSize: 字体尺寸
Dim textObj As AcadText
Dim xyz(2) As Double
Dim xyz1(2) As Double
Dim xyz2(2) As Double
If strNumPos = "f" Or strNumPos = "r" Then iDiff = 10
If strNumPos = "b" Or strNumPos = "l" Then iDiff = -10
xyz(0) = x0: xyz(1) = y0: xyz(2) = z0
xyz1(0) = x0 + iDiff: xyz1(1) = y0: xyz1(2) = z0
xyz2(0) = x0: xyz2(1) = y0 + iDiff: xyz2(2) = z0
Set textObj = ThisDrawing.ModelSpace.AddText(strText, xyz, iSize)
If strNumPos = "f" Or strNumPos = "l" Then
textObj.Alignment = acAlignmentRight
textObj.TextAlignmentPoint = xyz
End If
If strNumPos = "f" Or strNumPos = "b" Then
DblAngle = ThisDrawing.Utility.AngleToReal(-90, acDegrees)
textObj.Rotation = DblAngle
textObj.Move xyz, xyz2
ElseIf strNumPos = "l" Or strNumPos = "r" Then
textObj.Move xyz, xyz1
End If
End Sub