通過autoCAD-vba畫管道單線圖 [ v1.6 ]
阿新 • • 發佈：2019-01-11
更新版本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