工作中需要画大量单线图,如图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 - 向下
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