yang686526

抛砖引玉
www.dimcax.com
抛砖引玉
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
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.autocad.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
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
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"
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
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
这是我编的通用参数驱动程序，用的还是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)