更新版本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