更新版本v1.5：
1、支持空间方位，如lfu，表示左前上方
2、支持单引号注释，单行或语句后方
Sub main() ' ========================== ' 功能：根据list.txt内容绘制单选图 ' 版本：v1.5 ' 作者：end1n9@163.com #bin.xu ' 时间：2018-05-24 ' ' 0、字母说明： ' m: 起始坐标 ' u: 向上 ' d: 向下 ' f:前(北) ' | ' l:左(西) ――├―― r:右(东) ' | ' b:后(南) ' ' 1、字母后跟线段长度的整数倍（<10），缺省时为1个线段长度 ' 2、[v1.5] 支持空间方位，如lfu，表示左前上方 ' 3、[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") newFontFile = Application.Path & "\Fonts\txt.shx" textStyle1.Height = 10 If fso.FileExists(newFontFile) Then textStyle1.fontFile = newFontFile End If ' 获取list.txt路径 ret_loc = "0,0,0" listFilePath = InputBox("请输入《list.txt》文件路径") listFile = 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 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 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