【转帖】我写的excel与cad互相转换表格的程序。
 

我写的excel与cad互相转换表格的程序。
www.dimcax.com
我写的excel与cad互相转换表格的程序。
dim xcelapp as new excel.application
'由excel文件生成cad表格
sub excelread()
xcelapp.workbooks.open "d:\book3.xls", , readonly
dim i as integer
dim j as integer
i = 2
j = 65
with xcelapp.activeworkbook.worksheets("报价")
'获得行数
do
if .range("a" & i) = "" then
exit do
end if
i = i + 1
loop
'获得列数
do
if .range(chr(j) & "1") = "" then
exit do
end if
j = j + 1
loop
end with
call drawtable(i, j)
xcelapp.workbooks.close
xcelapp.quit
end sub
private sub drawtable(byval x as integer, byval y as integer)
dim newl as acadline '绘制直线
dim startp(2) as double '定义直线起点
dim endp(2) as double '定义直线终点
dim i as integer '循环变量
dim newtext1 as acadmtext
'定义直线起点
startp(0) = 0
startp(1) = 0
startp(2) = 0
'定义直线终点
endp(0) = 60 * (y - 65)
endp(1) = 0
endp(2) = 0
'画横线
do while i < x + 2
set newl = thisdrawing.modelspace.addline(startp, endp)
startp(1) = startp(1) + 10
endp(1) = endp(1) + 10
i = i + 1
loop
'画竖线，定义起始点
endp(0) = 0
endp(1) = 10 * (x + 1)
startp(1) = 0
startp(0) = 0
for i = 1 to y - 64
'画第一条竖线，并写入第一列文本
set newl = thisdrawing.modelspace.addline(startp, endp)
call addtext(endp(0), x, i)
startp(0) = startp(0) + 60
endp(0) = endp(0) + 60
next
thisdrawing.application.update
end sub
private sub addtext(byval x as double, byval rs as integer, byval cs as integer)
dim newtext as acadmtext '写入文本
dim insertp(2) as double '定义文本的插入点
dim i as integer
dim j as integer
j = 64 + cs
'获得文本的插入点
insertp(0) = x + 2
insertp(1) = (rs + 2) * 10 - 12.5
insertp(2) = 0
i = 1
do while i < rs
set newtext = thisdrawing.modelspace.addmtext(insertp, 50, xcelapp.activeworkbook.worksheets("报价").range(chr(j) & i))
newtext.height = 5
i = i + 1
insertp(1) = insertp(1) - 10
loop
end sub
'由cad表格转为excel表格
sub getdata()
dim sel as acadselectionset
dim i as integer
dim j as integer
dim start1 as variant
dim end1 as variant
dim str(300, 300) as string
dim newline as acadline
dim newmtext as acadmtext
dim rows as integer
dim cols as integer
dim rowlen as double
dim collen as double
on error resume next
'选择对象
set sel = thisdrawing.selectionsets.add("ssel")
if err then
err.clear
set sel = thisdrawing.selectionsets.item("ssel")
end if
on error goto 0
sel.selectonscreen
dim ent as acadentity
'计算行数及列数
for each ent in sel
if lcase(ent.objectname) = "acdbline" then
set newline = ent
start1 = newline.startpoint
end1 = newline.endpoint
if start1(0) = end1(0) then
j = j + 1
collen = newline.length
elseif start1(1) = end1(1) then
i = i + 1
rowlen = newline.length
end if
end if
next
for each ent in sel
'将文本写入数组
if lcase(ent.objectname) = "acdbmtext" then
set newmtext = ent
start1 = newmtext.insertionpoint
cols = start1(0) \ rowlen / (j - 1)
rows = i - start1(1) \ collen / (i - 1) - 2
str(rows, cols) = newmtext.textstring
end if
next
call writeexcel(str, i, j)
sel.delete
end sub
private sub writeexcel(byval p as variant, byval x as integer, byval y as integer)
dim i as integer
dim j as integer
dim excelapp as new excel.application
dim excelwkbk as excel.workbook
set excelwkbk = excelapp.workbooks.add
msgbox excelwkbk.name
with excelwkbk.worksheets("sheet1")
for i = 1 to x
for j = 65 to y + 65
.range(chr(j) & i) = p(i - 1, j - 65)
next
next
end with
excelapp.activeworkbook.saveas "d:\hxj.xls"
excelapp.workbooks.close
excelapp.quit
end sub
主要是针对联通设计院的模板生成表格，所以有点数据上面，主要是针对我的工作
还请lee版主及各位多提意见本帖dimcax次又得到您这么多帮助。就此贡献鲜花 一朵。呵呵：）thanks
请教
我在调试上面的代码时 for each ent in sel提示类型不匹配
应如何修改
谢谢
你是否忘记了dim ent as acadentity?
如果方便，请帖出你的部分代码。
楼主的代码和我写《vba读写excel数据的一般方法》中的代码都已经运行通过，不会出现你说的错误。