抛砖引玉

雪山飞狐_lzh

3.        Module mTlsCad
4.                Public Const strAppName As String = "TlsCad"
5.                Public Const tString As Short = 0
6.                Public Const tDouble As Short = 1
7.                Public Const tPoint As Short = 2
8.                Public Function LeftStr(ByVal String1 As Object, ByVal String2 As Object) As Object
9.                        Try
10.                                LeftStr = Left(String1, InStr(String1, String2) - 1)
11.                        Catch ex As Exception
12.                                LeftStr = False
13.                        End Try
14.                End Function
15.                Public Function RightStr(ByVal String1 As Object, ByVal String2 As Object) As Object
16.                        Try
17.                                RightStr = Right(String1, Len(String1) - Len(String2) - InStr(String1, String2) + 1)
18.                        Catch ex As Exception
19.                                RightStr = False
20.                        End Try
21.                End Function
22.        End Module       Public Class TlsApplication
23.                <CommandMethod("TlsCadRun")> Public Shared Sub TlsCadRun()
24.                        Dim pEntity As New TlsEntity
25.                        Dim aSub As String
26.                        Dim pACadApp As AcadApplication = Application.AcadApplication
27.                        Dim pACadDoc As AcadDocument = pACadApp.ActiveDocument
28.                        aSub = pACadDoc.Utility.GetString(0, "请输入函数:")
29.                        pEntity.Init()
30.                        pEntity.RunSub(aSub)
31.                        pEntity.Insert()
32.                End Sub       End Class       Public Class TlsData
33.                Public Type As Short
34.                Private p_sData As String
35.                Private p_dData As Double
36.                Private p_pData As Object
37.                Public Property sData() As String
38.                        Get
39.                                sData = p_sData
40.                        End Get
41.                        Set(ByVal Value As String)
42.                                Dim pnt As Object
43.                                Dim i As Object
44.                                Dim pStr As String
45.                                p_sData = Value
46.                                pStr = Left(Value, 1)
47.                                Type = tString
48.                                If pStr >= "0" And pStr <= "9" Then
49.                                        If InStr(1, Value, ",") > 0 Then
50.                                                pnt = Split(Value, ",")
51.                                                For i = 0 To 2
52.                                                        p_pData(i) = pnt(i)
53.                                                Next i
54.                                                Type = tPoint
55.                                        Else
56.                                                p_dData = Val(Value)
57.                                                Type = tDouble
58.                                        End If
59.                                End If
60.                        End Set
61.                End Property
62.                Public Property X() As Double
63.                        Get
64.                                X = p_pData(0)
65.                        End Get
66.                        Set(ByVal Value As Double)
67.                                p_pData(0) = Value
68.                        End Set
69.                End Property
70.                Public Property Y() As Double
71.                        Get
72.                                Y = p_pData(1)
73.                        End Get
74.                        Set(ByVal Value As Double)
75.                                p_pData(1) = Value
76.                        End Set
77.                End Property
78.                Public Property Z() As Double
79.                        Get
80.                                Z = p_pData(2)
81.                        End Get
82.                        Set(ByVal Value As Double)
83.                                p_pData(2) = Value
84.                        End Set
85.                End Property
86.                Public Property dData() As Double
87.                        Get
88.                                dData = p_dData
89.                        End Get
90.                        Set(ByVal Value As Double)
91.                                p_dData = Value
92.                        End Set
93.                End Property
94.                Public Property pData() As Object
95.                        Get
96.                                pData = p_pData
97.                        End Get
98.                        Set(ByVal Value As Object)
99.                                p_pData = Value
100.                        End Set
101.                End Property
102.                Public Sub New()
103.                        Dim pnt(2) As Double
104.                        p_pData = pnt
105.                End Sub
106.        End Class       Public Class TlsObject
107.                Protected Name As String = "TlsObject"
108.                Protected pACadApp As AcadApplication = Application.AcadApplication
109.                Protected pACadDoc As AcadDocument = pACadApp.ActiveDocument
110.                Protected pACadMSpace As Autodesk.AutoCAD.Interop.Common.AcadModelSpace = pACadApp.ActiveDocument.ModelSpace
111.                Protected pObj As Autodesk.AutoCAD.Interop.Common.AcadObject
112.                Protected Overridable Sub Save()
113.                        Dim hDataType(1) As Short, hData(1) As Object
114.                        hDataType(0) = 1001 : hData(0) = strAppName
115.                        hDataType(1) = 1000 : hData(1) = Name
116.                        pObj.SetXData(hDataType, hData)
117.                End Sub
118.                Public Overridable Sub Insert()
119.                End Sub
120.                Public Overridable Sub Change()
121.                End Sub
122.        End Class

       Module mTlsCad                Public Const strAppName As String = "TlsCad"                Public Const tString As Short = 0                Public Const tDouble As Short = 1                Public Const tPoint As Short = 2                Public Function LeftStr(ByVal String1 As Object, ByVal String2 As Object) As Object                        Try                                LeftStr = Left(String1, InStr(String1, String2) - 1)                        Catch ex As Exception                                LeftStr = False                        End Try                End Function                Public Function RightStr(ByVal String1 As Object, ByVal String2 As Object) As Object                        Try                                RightStr = Right(String1, Len(String1) - Len(String2) - InStr(String1, String2) + 1)                        Catch ex As Exception                                RightStr = False                        End Try                End Function        End Module       Public Class TlsApplication                <CommandMethod("TlsCadRun")> Public Shared Sub TlsCadRun()                        Dim pEntity As New TlsEntity                        Dim aSub As String                        Dim pACadApp As AcadApplication = Application.AcadApplication                        Dim pACadDoc As AcadDocument = pACadApp.ActiveDocument                        aSub = pACadDoc.Utility.GetString(0, "请输入函数:")                        pEntity.Init()                        pEntity.RunSub(aSub)                        pEntity.Insert()                End Sub       End Class       Public Class TlsData                Public Type As Short                Private p_sData As String                Private p_dData As Double                Private p_pData As Object                Public Property sData() As String                        Get                                sData = p_sData                        End Get                        Set(ByVal Value As String)                                Dim pnt As Object                                Dim i As Object                                Dim pStr As String                                p_sData = Value                                pStr = Left(Value, 1)                                Type = tString                                If pStr >= "0" And pStr <= "9" Then                                        If InStr(1, Value, ",") > 0 Then                                                pnt = Split(Value, ",")                                                For i = 0 To 2                                                        p_pData(i) = pnt(i)                                                Next i                                                Type = tPoint                                        Else                                                p_dData = Val(Value)                                                Type = tDouble                                        End If                                End If                        End Set                End Property                Public Property X() As Double                        Get                                X = p_pData(0)                        End Get                        Set(ByVal Value As Double)                                p_pData(0) = Value                        End Set                End Property                Public Property Y() As Double                        Get                                Y = p_pData(1)                        End Get                        Set(ByVal Value As Double)                                p_pData(1) = Value                        End Set                End Property                Public Property Z() As Double                        Get                                Z = p_pData(2)                        End Get                        Set(ByVal Value As Double)                                p_pData(2) = Value                        End Set                End Property                Public Property dData() As Double                        Get                                dData = p_dData                        End Get                        Set(ByVal Value As Double)                                p_dData = Value                        End Set                End Property                Public Property pData() As Object                        Get                                pData = p_pData                        End Get                        Set(ByVal Value As Object)                                p_pData = Value                        End Set                End Property                Public Sub New()                        Dim pnt(2) As Double                        p_pData = pnt                End Sub        End Class       Public Class TlsObject                Protected Name As String = "TlsObject"                Protected pACadApp As AcadApplication = Application.AcadApplication                Protected pACadDoc As AcadDocument = pACadApp.ActiveDocument                Protected pACadMSpace As Autodesk.<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.Interop.Common.AcadModelSpace = pACadApp.ActiveDocument.ModelSpace                Protected pObj As Autodesk.AutoCAD.Interop.Common.AcadObject                Protected Overridable Sub Save()                        Dim hDataType(1) As Short, hData(1) As Object                        hDataType(0) = 1001 : hData(0) = strAppName                        hDataType(1) = 1000 : hData(1) = Name                        pObj.SetXData(hDataType, hData)                End Sub                Public Overridable Sub Insert()                End Sub                Public Overridable Sub Change()                End Sub        End Class

雪山飞狐_lzh

Public Class TlsEntity
Inherits TlsObject
Private pTlsVals As New Collection
'变量集合
Private Shared pSubs As New Collection
'函数集合
Private Shared pBlock As Autodesk.AutoCAD.Interop.Common.AcadBlock
Private pMirrorStart, pArrayStart As Short
Private dDataType(50) As Short, dData(50) As Object
Public Sub New()
Dim i As Object
Dim pData As TlsData
Name = "TlsEntity"
pData = New TlsData : pData.sData = "0,0,0" : pTlsVals.Add(pData, "PS")
'定义初始点
pData = New TlsData : pData.sData = "0" : pTlsVals.Add(pData, "Start")
'旋转或镜像开始
pData = New TlsData : pData.sData = "0" : pTlsVals.Add(pData, "End")
'旋转或镜像结束
pData = New TlsData : pData.sData = "01" : pTlsVals.Add(pData, "CSX")
pData = New TlsData : pData.sData = "02" : pTlsVals.Add(pData, "XSX")
pData = New TlsData : pData.sData = "03" : pTlsVals.Add(pData, "ZXX")
pData = New TlsData : pData.sData = "04" : pTlsVals.Add(pData, "XX")
'图层定义
dDataType(0) = 1001 : dData(0) = "EntityDefine"
dDataType(1) = 1000 : dData(1) = ""
For i = 2 To 30
dDataType(i) = 1040 : dData(i) = 0
Next i
For i = 31 To 50
dDataType(i) = 1070 : dData(i) = 0
Next i
'扩张数据初始化 End Sub
Public Sub Init()
'块初始化
Dim pnt(2) As Double
OpenFile()
pBlock = pACadDoc.Blocks.Add(pnt, "*U")
End Sub
Public Property EntityName() As String
'实体名属性
Get
EntityName = dData(1)
End Get
Set(ByVal Value As String)
dData(1) = Value
End Set
End Property
Private Property XData(ByVal Index As Short) As Double
'实体参数属性
Get
XData = dData(Index + 10)
End Get
Set(ByVal Value As Double)
dData(Index + 10) = Value
End Set
End Property
Protected Overrides Sub Save()
MyBase.Save()
pObj.SetXData(dDataType, dData)
End Sub
Public Overrides Sub Insert()
Dim pnt As Object
Try
pnt = pACadDoc.Utility.GetPoint(, "请输入插入点:")
pObj = pACadMSpace.InsertBlock(pnt, pBlock.Name, 1, 1, 1, 0)
pObj.Rotate(pnt, pACadDoc.Utility.GetAngle(pnt, "请输入旋转角度:"))
Save()
Catch ex As Exception
End Try
End Sub
Private Sub StrCal(ByVal String1 As Object)
'函数运算器
Dim i As Object
Dim pCals As Collection
Dim pStrack1 As New Collection
Dim pStrack2 As Collection
Try
pCals = CutStr(String1)
'分解一行语句
For i = 1 To pCals.Count
If pCals(i).sData <> ")" Then
'不是)时顺序入栈
pStrack1.Add(pCals(i))
Else
'遇")"时顺序出栈到"("
pStrack2 = New Collection
Do While pStrack1(pStrack1.Count).sData <> "("
pStrack2.Add(pStrack1(pStrack1.Count))
pStrack1.Remove(pStrack1.Count)
Loop
pStrack1.Remove(pStrack1.Count)
pStrack1.Add(GetVal(pStrack2))
'计算结果并入栈
End If
Next i
Catch ex As Exception
End Try
End Sub
Private Function CutStr(ByVal String1 As Object) As Collection
'分解一行语句
Dim i, j As Object
Dim pStrack As Object
Dim pCals As New Collection
Dim pData As TlsData
Try
pStrack = Split(String1, " ")
'先按空格分解
If Not IsArray(pStrack) Then Exit Try
For Each i In pStrack
If InStr(1, i, "(") = 1 Then
'有"("时
pData = New TlsData
pData.sData = "("
pCals.Add(pData)
If RightStr(i, "(") <> "" Then
pData = New TlsData
pData.sData = RightStr(i, "(")
pCals.Add(pData)
End If
ElseIf InStr(1, i, ")") > 1 Then
'有")"时
pData = New TlsData
pData.sData = LeftStr(i, ")")
pCals.Add(pData)
For j = 1 To Len(RightStr(i, ")")) + 1
pData = New TlsData
pData.sData = ")"
pCals.Add(pData)
Next j
ElseIf Trim(i) <> "" Then
'去除空字符
pData = New TlsData
pData.sData = i
pCals.Add(pData)
End If
Next i
Catch ex As Exception
Finally
CutStr = pCals
End Try
End Function

雪山飞狐_lzh

Private Function GetVal(ByVal Strack As Collection) As TlsData
'计算函数结果
Dim pData As New TlsData
Dim pCals As New Collection
Dim Count As Integer
Dim pMinCount As Integer
Dim i As Object
Try
Count = Strack.Count
For i = Count To 1 Step -1
pCals.Add(Strack(i))
Next i
pMinCount = 2 : If pCals(1).sData.ToUpper = "SUB" Or pCals(1).sData.ToUpper = "CALL" Then pMinCount = 3
If UCase(pCals(1).sData) = "VALUE" Or UCase(pCals(1).sData) = "SUB" Then
For i = pMinCount To Count
If InStr(pCals(i).sData, "#") > 0 Then
pData = New TlsData : pData.sData = "0,0,0"
pTlsVals.Add(pData, LeftStr(pCals(i).sData, "#"))
Else
pData = New TlsData : pData.sData = "0"
pTlsVals.Add(pData, pCals(i).sData)
End If
Next i
Exit Function
End If
For i = pMinCount To Count
If pCals(i).Type = tString Then
pCals(i).dData = pTlsVals(pCals(i).sData).dData
pCals(i).pData = pTlsVals(pCals(i).sData).pData
pCals(i).Type = pTlsVals(pCals(i).sData).Type
End If
Next i
Select Case pCals(1).sData.ToUpper
Case "="
If Count = 6 Then
pTlsVals(pCals(2).sData).X = pCals(3).X + pCals(4).dData
pTlsVals(pCals(2).sData).Y = pCals(3).Y + pCals(5).dData
pTlsVals(pCals(2).sData).Z = pCals(3).Z + pCals(6).dData
Else
pTlsVals(pCals(2).sData).dData = pCals(3).dData
pTlsVals(pCals(2).sData).pData = pCals(3).pData
End If
pData = pTlsVals(pCals(2).sData)
Case "+"
pData.sData = "0"
pData.dData = pCals(2).dData + pCals(3).dData
Case "-"
pData.sData = "0"
If Count = 3 Then
pData.dData = pCals(2).dData - pCals(3).dData
Else
pData.dData = -pCals(2).dData
End If
Case "*"
pData.sData = "0"
pData.dData = pCals(2).dData * pCals(3).dData
Case "/"
pData.sData = "0"
pData.dData = pCals(2).dData / pCals(3).dData
Case "^"
pData.sData = "0"
pData.dData = pCals(2).dData ^ pCals(3).dData
Case "CALL"
Dim pTlsEntity As New TlsEntity
Dim pValues As String
pValues = pCals(2).sData + "("
For i = 3 To pCals.Count - 1
pValues = pValues + Convert.ToString(pCals(i).dData) + ","
Next i
pValues = pValues + Convert.ToString(pCals(pCals.Count).dData) + ")"
pTlsEntity.RunSub(pValues)
Case "LINE"

雪山飞狐_lzh

pBlock.AddLine(pCals(2).pData, pCals(3).pData).Layer = pTlsVals(pCals(4).sData).sData
Case "CIRCLE"
pBlock.AddCircle(pCals(2).pData, pCals(3).dData).Layer = pTlsVals(pCals(4).sData).sData
Case "ELLIPSE"
Dim obj As Autodesk.AutoCAD.Interop.Common.AcadEllipse
obj = pBlock.AddEllipse(pCals(2).pData, pCals(3).pData, pCals(4).dData)
obj.StartAngle = pCals(5).dData / 45 * System.Math.Atan(1)
obj.EndAngle = pCals(6).dData / 45 * System.Math.Atan(1)
obj.Layer = pTlsVals(pCals(7).sData).sData
Case "ARC"
pBlock.AddArc(pCals(2).pData, pCals(3).dData, pCals(4).dData / 45 * System.Math.Atan(1), pCals(5).dData / 45 * System.Math.Atan(1)).Layer = pTlsVals(pCals(6).sData).sData
Case "MIRROR"
If pCals(2).sData = "Start" Then
pMirrorStart = pBlock.Count
Else
For i = pMirrorStart To pBlock.Count - 1
pBlock.Item(i).Mirror(pCals(2).pData, pCals(3).pData)
Next i
End If
Case "ARRAY"
If pCals(2).sData = "Start" Then
pArrayStart = pBlock.Count
Else
If Count = 4 Then
For i = pArrayStart To pBlock.Count - 1
pBlock.Item(i).ArrayPolar(pCals(3).dData, pCals(4).dData, pCals(2).pData)
Next i
Else
For i = pArrayStart To pBlock.Count - 1
pBlock.Item(i).ArrayRectangular(pCals(2).dData, pCals(3).dData, 1, pCals(4).dData, pCals(5).dData, 0)
Next i
End If
End If
Case "HATCH"
End Select
Catch ex As Exception
Finally
GetVal = pData
End Try
End Function
Private Sub OpenFile()
'读取函数文件
Dim i As Object
Dim ts As StreamReader
Dim Data As String
Dim allSub As Object
Dim aSub As Collection
Dim FileName As String
For i = 1 To pSubs.Count
pSubs.Remove(1)
Next i
Try
ts = File.OpenText(Directory.GetCurrentDirectory & "\TlsCad.Sub")
allSub = Split(ts.ReadToEnd, vbCrLf)
For i = 0 To UBound(allSub)
Data = allSub(i)
If InStr(Data, "(Sub") = 1 Then
'向函数集合加入新函数
aSub = New Collection
pSubs.Add(aSub, CutStr(Data)(3).sData)
pSubs(pSubs.Count).Add(Data)
Else
pSubs(pSubs.Count).Add(Data)
End If
Next i
Catch ex As Exception
Finally
ts.Close()
End Try
End Sub

雪山飞狐_lzh

Public Sub RunSub(ByVal String1 As String)
Dim i As Object
Dim aSub As Collection
Dim pValues As Object
Try
EntityName = Trim(LeftStr(String1, "(")).ToUpper
aSub = pSubs(EntityName)
StrCal(aSub(1))
'分配函数变量
pValues = Split(LeftStr(RightStr(String1, "("), ")"), ",")
If IsArray(pValues) Then
'初始化函数变量
For i = 0 To UBound(pValues)
pTlsVals(i + 8).dData = pValues(i)
XData(i) = pValues(i)
Next i
End If
For i = 2 To aSub.Count
'依次运行语句
StrCal(aSub(i))
Next i
Catch ex As Exception
End Try
End Sub End Class

雪山飞狐_lzh

这是我编的通用参数驱动程序，用的还是ActiveX方法 将下面的文本存为TlsCad.sub文件和编译后的Dll文件放在同一目录下就可以使用了 (Sub TYFT_EHA Dn H h1 d)
(Value a1 a2 a3 a4 a5 a6 p1# p2#)
(= a3 (- (= a2 (/ (= a1 (+ Dn (* d 2))) 2))))
(= a4 (/ (* (- H h1 ) 2) Dn))
(= a5 (/ (* (+ (- H h1) d) 2) a1))
(= a6 (/ Dn 2))
(= p2 (= p1 ps a3 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 p1 d 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 p1 Dn 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 p1 d 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 ps a3 0 0) a1 0 0)
(Line p1 p2 CSX)
(= p1 ps 0 h1 0)
(= p2 ps a6 0 0)
(Ellipse p1 p2 a4 0 180 CSX)
(= p2 ps a2 0 0)
(Ellipse p1 p2 a5 0 180 CSX)
(End Sub)
(Sub TYFT_EHB Dn H h1 d)
(Value a1 a2 a3 a4 a5 a6 p1# p2#)
(= Dn (- Dn (* 2 d)))
(= H (- H d))
(= a3 (- (= a2 (/ (= a1 (+ Dn (* d 2))) 2))))
(= a4 (/ (* (- H h1 ) 2) Dn))
(= a5 (/ (* (+ (- H h1) d) 2) a1))
(= a6 (/ Dn 2))
(= p2 (= p1 ps a3 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 p1 d 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 p1 Dn 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 p1 d 0 0) 0 h1 0)
(Line p1 p2 CSX)
(= p2 (= p1 ps a3 0 0) a1 0 0)
(Line p1 p2 CSX)
(= p1 ps 0 h1 0)
(= p2 ps a6 0 0)
(Ellipse p1 p2 a4 0 180 CSX)
(= p2 ps a2 0 0)
(Ellipse p1 p2 a5 0 180 CSX)
(End Sub) 命令格式： TlsCadRun tyft_eha(300,100,25,4)

yfy2003

好贴！

cag

不明白怎么用?

雪山飞狐_lzh

把代码全部复制到TlsCad.vb文件内，加入下列代码 Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Interop
Imports System.IO
编译为Dll文件，用NetLoad加载一下

ahlzl

我水平低，还不能看懂，有一个问题先问lzh741206一下：

1. Public Const strAppName As String = "TlsCad"

复制代码

在VB。NET中是不是可在声明的同时赋值？！