更新版本v1.7：
1、代码重构。终于抽出时间。
2、[v1.7] v - 表示阀门，后跟两个焊口号，以逗号分隔，阀门只支持6个方位，即fblrud
' list.txt
m,100,100,100
NumPos=b
b,ZQ3-YJ03-D114-1.2-1+2W
uv,ZQ3-YJ03-N1-D114-1.2-3F,ZQ3-YJ03-N1-D114-1.2-4F
b,ZQ3-YJ03-D114-1.2-1+5W' ==========================
' 功能：根据list.txt内容绘制单选图
' 版本：v1.7
' 作者：[email protected] #bin.xu
' 时间：2018-06-04
'
' 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
' 1.7、[v1.7] v - 表示阀门，后跟两个焊口号，以逗号分隔
' 阀门只支持6个方位，即fblrud
'
' 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 ' 之后的编号在圆点左侧标注
' fv,ZQ3-YJ03-N1-D114-1.2-3F,ZQ3-YJ03-N1-D114-1.2-4F ' 阀门
'
' ==========================
Sub main()
Dim ret
Dim strListFile As String
ret = fn_setFont("txt.shx")
strListFile = fn_getListPath("~setting.tmp")
ret = fn_anayleFile(strListFile)
ThisDrawing.Regen True
' 西南等轴侧
ThisDrawing.SendCommand "-view" & vbCr & "swiso" & vbCr
ZoomAll
End Sub
' /////////////////////////////////////
Function fn_setFont(strFont As String)
' 设置字体文件
fn_setFont = 0
Dim newFontFile As String
Dim textStyle1 As AcadTextStyle
Set textStyle1 = ThisDrawing.ActiveTextStyle
Set fso = CreateObject("Scripting.FileSystemObject")
Set sh = CreateObject("WScript.Shell")
newFontFile = Application.Path & "\Fonts\" & strFont
textStyle1.Height = 10
If fso.FileExists(newFontFile) Then
textStyle1.fontFile = newFontFile
End If
fn_setFont = -1
End Function
' /////////////////////////////////////
Function fn_getListPath(strFileName As String)
' 获取list.txt文件路径，并保存
fn_getListPath = 0
Dim strListFilePath As String
Dim strTmpPath As String
Dim strListFile As String
Dim sh, fso
Set sh = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
strListFilePath = ""
' 获取~setting.tmp文件
strTmpPath = sh.ExpandEnvironmentStrings("%TMP%")
strTmpPath = strTmpPath & "\" & strFileName
If fso.FileExists(strTmpPath) Then
Open strTmpPath For Input As #1
Do While Not EOF(1)
Line Input #1, rLine
strListFilePath = CStr(rLine)
Loop
Close #1
End If
' 获取list.txt路径
strListFilePath = InputBox("请输入《list.txt》文件路径", "输入", strListFilePath)
strListFile = Replace(strListFilePath, """", "") & "\list.txt"
' 路径写入~setting.tmp文件
If fso.FileExists(strListFile) Then
Open strTmpPath For Output As #1
Write #1, Replace(strListFilePath, """", "")
Close #1
End If
fn_getListPath = strListFile
End Function
' /////////////////////////////////////
Function fn_anayleFile(strFileName As String)
fn_anayleFile = 0
Dim ret_xyz(0 To 2) As Double
Dim strNumPos As String
Dim listFile As String
Dim rLine As String
Dim arr_xyz ' split(str,",")
Dim ret
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
ret_xyz(0) = 0: ret_xyz(1) = 0: ret_xyz(2) = 0
strNumPos = "f"
listFile = strFileName
' 分析文件内容
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
' 起始坐标
arr_xyz = Split(rLine, ",")
ret_xyz(0) = arr_xyz(1)
ret_xyz(1) = arr_xyz(2)
ret_xyz(2) = arr_xyz(3)
ElseIf LCase(Mid(rLine, 1, 6)) = "numpos" Then
' 编号显示方位
strNumPos = Mid(StrReverse(rLine), 1, 1)
If InStr(strNumPos, "f") = 0 And _
InStr(strNumPos, "b") = 0 And _
InStr(strNumPos, "l") = 0 And _
InStr(strNumPos, "r") = 0 Then
strNumPos = "f"
End If
Else
ret = fn_drawObject(ret_xyz, rLine, strNumPos)
ret_xyz(0) = ret(0)
ret_xyz(1) = ret(1)
ret_xyz(2) = ret(2)
End If
End If
Loop
Close #1
End If
ThisDrawing.Regen True
fn_anayleFile = -1
End Function
' /////////////////////////////////////
Function fn_drawObject(xyz0() As Double, strstr As String, strNumPos As String)
' 画实例，包含线，实心圆，编号
fn_drawObject = 0
Dim arrStr
Dim strFirstSec As String
Dim strDirection As String
Dim iMul As Integer
Dim strTextPos As String
Dim strText As String
strTextPos = 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
' 倍数
iMul = 1
If Len(strFirstSec) > 1 And IsNumeric(Mid(StrReverse(strFirstSec), 1, 1)) = True Then
iMul = CInt(Mid(StrReverse(strFirstSec), 1, 1))
End If
' 编号及方向
strText = Mid(strstr, InStr(strstr, ",") + 1)
strText = Replace(Trim(strText), " ", "")
If InStr(arrStr(1), "=") <> 0 Then
strTextPos = Mid(strText, 1, 1)
strText = Mid(strText, 3)
End If
If InStr(strFirstSec, "v") <> 0 Then
' 画阀门
fn_drawObject = fn_drawValve(xyz0, iMul, strDirection, strText, strTextPos)
Else
' 画线段
fn_drawObject = fn_drawPloyline(xyz0, iMul, strDirection, strText, strTextPos)
End If
End Function
' /////////////////////////////////////
Function fn_drawPloyline(xyz0() As Double, iMul As Integer, strDirection As String, strText As String, strTextPos As String)
fn_drawPloyline = 0
Dim xyz1(0 To 2) As Double
Dim xyz(0 To 5) As Double
Dim xyzText(0 To 2) As Double
Dim iLen As Integer
Dim objPL As Acad3DPolyline
Dim color As New AcadAcCmColor
xyz1(0) = xyz0(0)
xyz1(1) = xyz0(1)
xyz1(2) = xyz0(2)
iLen = 80 ' 线段默认长度
iLen = iMul * iLen
color.SetRGB 0, 255, 255
If InStr(strDirection, "f") <> 0 Then xyz1(1) = xyz0(1) + iLen
If InStr(strDirection, "b") <> 0 Then xyz1(1) = xyz0(1) - iLen
If InStr(strDirection, "l") <> 0 Then xyz1(0) = xyz0(0) - iLen
If InStr(strDirection, "r") <> 0 Then xyz1(0) = xyz0(0) + iLen
If InStr(strDirection, "u") <> 0 Then xyz1(2) = xyz0(2) + iLen
If InStr(strDirection, "d") <> 0 Then xyz1(2) = xyz0(2) - iLen
xyz(0) = xyz0(0): xyz(1) = xyz0(1): xyz(2) = xyz0(2)
xyz(3) = xyz1(0): xyz(4) = xyz1(1): xyz(5) = xyz1(2)
' 画线
Set objPL = ThisDrawing.ModelSpace.Add3DPoly(xyz)
objPL.Lineweight = acLnWt030 ' 线宽
objPL.TrueColor = color ' 颜色
' 中间点坐标
xyzText(0) = (xyz0(0) + xyz1(0)) / 2
xyzText(1) = (xyz0(1) + xyz1(1)) / 2
xyzText(2) = (xyz0(2) + xyz1(2)) / 2
' 画中间点
Call fn_drawCircle(xyzText)
' 写文字
Call fn_drawText(xyzText, strText, strTextPos)
fn_drawPloyline = xyz1
End Function
' /////////////////////////////////////
Function fn_drawValve(xyz0() As Double, iMul As Integer, strDirection As String, strText As String, strTextPos As String)
fn_drawValve = 0
Dim xyz1(0 To 2) As String
Dim objPL(7) As Acad3DPolyline
Dim xyz(5) As Double
' 构造阀门，向右画
xyz(0) = xyz0(0): xyz(1) = xyz0(1): xyz(2) = xyz0(2)
xyz(3) = xyz0(0) + 60: xyz(4) = xyz0(1): xyz(5) = xyz0(2)
Set objPL(0) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(0) = xyz(3): xyz(2) = xyz(5) + 20: xyz(5) = xyz(5) - 20
Set objPL(1) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(0) = xyz(0) + 10: xyz(3) = xyz(3) + 10
Set objPL(2) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(3) = xyz(3) + 40
Set objPL(3) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(2) = xyz(2) - 40: xyz(5) = xyz(5) + 40
Set objPL(4) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(0) = xyz(0) + 40
Set objPL(5) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(0) = xyz(0) + 10: xyz(3) = xyz(3) + 10
Set objPL(6) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
xyz(2) = xyz(2) + 20: xyz(3) = xyz(3) + 60: xyz(5) = xyz(5) - 20
Set objPL(7) = ThisDrawing.ModelSpace.Add3DPoly(xyz)
' 转向
Dim rotatePt1(0 To 2) As Double
Dim rotatePt2(0 To 2) As Double
Dim rotateAngle
Dim xyzText1(0 To 2) As Double
Dim xyzText2(0 To 2) As Double
Dim arrStr
' 旋转轴第二个点
rotatePt2(0) = xyz0(0)
rotatePt2(1) = xyz0(1)
rotatePt2(2) = xyz0(2)
' 两个编号坐标
xyzText1(0) = xyz0(0)
xyzText1(1) = xyz0(1)
xyzText1(2) = xyz0(2)
xyzText2(0) = xyz0(0)
xyzText2(1) = xyz0(1)
xyzText2(2) = xyz0(2)
' 阀门末尾坐标
xyz1(0) = xyz0(0)
xyz1(1) = xyz0(1)
xyz1(2) = xyz0(2)
' 坐标转换
rotateAngle = 0
If InStr(strDirection, "f") <> 0 Then
rotateAngle = 90: rotatePt2(2) = xyz0(2) + 10
xyzText1(1) = xyzText1(1) + 50: xyzText2(1) = xyzText2(1) + 130
xyz1(1) = xyz1(1) + 180
ElseIf InStr(strDirection, "b") <> 0 Then
rotateAngle = -90: rotatePt2(2) = xyz0(2) + 10
xyzText1(1) = xyzText1(1) - 50: xyzText2(1) = xyzText2(1) - 130
xyz1(1) = xyz1(1) - 180
ElseIf InStr(strDirection, "r") <> 0 Then
' 默认，不需要处理旋转
xyzText1(0) = xyzText1(0) + 50: xyzText2(0) = xyzText2(0) + 130
xyz1(0) = xyz1(0) + 180
ElseIf InStr(strDirection, "l") <> 0 Then
rotateAngle = 180: rotatePt2(2) = xyz0(2) + 10
xyzText1(0) = xyzText1(0) - 50: xyzText2(0) = xyzText2(0) - 130
xyz1(0) = xyz1(0) - 180
ElseIf InStr(strDirection, "u") <> 0 Then
rotateAngle = 90: rotatePt2(1) = xyz0(1) - 10
xyzText1(2) = xyzText1(2) + 50: xyzText2(2) = xyzText2(2) + 130
xyz1(2) = xyz1(2) + 180
ElseIf InStr(strDirection, "d") <> 0 Then
rotateAngle = -90: rotatePt2(1) = xyz0(1) - 10
xyzText1(2) = xyzText1(2) - 50: xyzText2(2) = xyzText2(2) - 130
xyz1(2) = xyz1(2) - 180
End If
rotateAngle = rotateAngle * 3.141592 / 180#
rotatePt1(0) = xyz0(0)
rotatePt1(1) = xyz0(1)
rotatePt1(2) = xyz0(2)
' 旋转
If rotateAngle <> 0 Then
For i = 0 To UBound(objPL)
objPL(i).Rotate3D rotatePt1, rotatePt2, rotateAngle
Next
End If
' 画中间点
Call fn_drawCircle(xyzText1)
Call fn_drawCircle(xyzText2)
' 写文字
arrStr = Split(strText, ",")
Call fn_drawText(xyzText1, Trim(arrStr(0)), strTextPos)
Call fn_drawText(xyzText2, Trim(arrStr(1)), strTextPos)
fn_drawValve = xyz1
End Function
' /////////////////////////////////////
Function fn_drawCircle(xyz1() As Double)
fn_drawCircle = 0
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) = xyz1(0): xyz(1) = xyz1(1): xyz(2) = xyz1(2)
xyz0(0) = xyz1(0): xyz0(1) = xyz1(1): 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
fn_drawCircle = -1
End Function
' /////////////////////////////////////
Function fn_drawText(xyz0() As Double, strText As String, strTextPos As String)
fn_drawText = 0
Dim textObj As AcadText
Dim xyz(2) As Double
Dim xyz1(2) As Double
Dim xyz2(2) As Double
Dim iSize
Dim iDiff
iDiff = 10
iSize = 10
If strTextPos = "f" Or strTextPos = "r" Then iDiff = 10
If strTextPos = "b" Or strTextPos = "l" Then iDiff = -10
xyz(0) = xyz0(0): xyz(1) = xyz0(1): xyz(2) = xyz0(2)
xyz1(0) = xyz0(0) + iDiff: xyz1(1) = xyz0(1) + 3: xyz1(2) = xyz0(2)
xyz2(0) = xyz0(0) + 3: xyz2(1) = xyz0(1) + iDiff: xyz2(2) = xyz0(2)
Set textObj = ThisDrawing.ModelSpace.AddText(strText, xyz, iSize)
If strTextPos = "f" Or strTextPos = "l" Then
textObj.Alignment = acAlignmentRight
textObj.TextAlignmentPoint = xyz
End If
If strTextPos = "f" Or strTextPos = "b" Then
DblAngle = ThisDrawing.Utility.AngleToReal(-90, acDegrees)
textObj.Rotation = DblAngle
textObj.Move xyz, xyz2
ElseIf strTextPos = "l" Or strTextPos = "r" Then
textObj.Move xyz, xyz1
End If
fn_drawText = -1
End Function
