CAD文字提取到EXCEL表格.docx
- 文档编号:1102164
- 上传时间:2022-10-17
- 格式:DOCX
- 页数:12
- 大小:190.99KB
CAD文字提取到EXCEL表格.docx
《CAD文字提取到EXCEL表格.docx》由会员分享,可在线阅读,更多相关《CAD文字提取到EXCEL表格.docx(12页珍藏版)》请在冰豆网上搜索。
CAD文字提取到EXCEL表格
CAD文字提取到EXCEL表格
天工作时碰到一个问题,在接到的某个cad图纸中,作者制作了材料表,见下图
该作者制作该表时,是画了直线和用多行文字,并没有用到cad的表格功能,或者链接excel的表格(这样作表格十分辛苦呢,呵呵)
但是我又恰恰要用到这个表格的数据,本人一向很懒,本来这么点东西直接重新照着在excel里打一次也用不了多少时间,可是我想有没有什么办法能直接提取这些文字出来呢,省得打了,最开始我就用了我一向喜欢的CAjViewer7.0,之前统计xsbf老师图片上的文字就是用它,CAjViewer7.0有汉字识别系统,能将图片上的文字识别为文本文字,于是截图,转换为pdf文件,用CAjViewer7.0打开,文字识别,结果效果不理想,全是乱码。
于是上网查找,终于找到一个工具可以实现,工具的来源请看标题
效果如下
[本帖最后由truezx于2008-10-1516:
31编辑]
CAD文字提取到EXCEL表格
将CAD中表格中文字(单行文字,多行文字应炸开)按坐标位置关系提取到EXCEL中的程序如下
(LOAD"TBL")
TXTTBL
工具的使用方法如下:
1、选择你要复制的所有文字(可以用快速选择),然后点击分解,炸开这些文字
2、cad中打开"工具"----"加载应用程序”----选择文件夹中的tbl.fas
命令行提示:
已成功加载tbl.fas
3、命令行输入:
txttbl
然后命令行提示:
scliukejunQQ:
303810,三维网2007年6月
选择对象:
框选你要复制的文字
4、确认后,提示你是要保存,还是打开,选择打开后就是一楼第二张图片的效果了(具体界面看三楼的图)。
[本帖最后由truezx于2008-10-1511:
37编辑]
tbl.rar
作者:
truezx 发布日期:
2008-10-15
另外一个工具,也是那个论坛完全转贴过来的
加载LISP
(load"tbl")
运行用
tbl
点选一CAD表格图元,完后弹出一对话框,
选打开
tbl2.rar
提取cad表格到excel,源码公开
本程序是本人接触cad以来一直在做的东东,不断的完善,当我程序的功能还不满意的时候,一直在网上找truetable这个软件,对里面的变编程原理非常感兴趣,现在随着在名经通道得到efan2000,lzh741206斑竹的帮助,终于实现了自己的程序功能,愿公布自己的源码,使很多象我一样对原理感兴趣的朋友心中释然,并在实际的工作中随心所欲编写出满足自己要求的程序,
本程序设定了两个控制变量,根据变量的值确定程序的执行路线,
tablescale确定当采用固定表格格式时,表格的比例
judgeselectp的取值决定用户决定是自己选择点还是采用固定的表格格式
还有一直形式就是在用户选择了所要转换的文字时,完全智能化,这样的功能我在microstationvba的编程中已经实现,在本程序的基础上实现也相当容易,但考虑到这种方法没有什么实际的意义,所以在cad里面没有做这个工作,希望对大家有帮助!
OptionExplicit
PublicSubbestt()
'linkexcel
DimappexcelAsExcel.Application
DimworksheetsAsExcel.worksheets
DimworkbooksAsExcel.workbooks
DimworkbookAsExcel.workbook
DimworksheetAsExcel.worksheet
DimworksheetnameAsString
DimrowscountAsInteger
DimporlineAsInteger
DimmultinumAsInteger
DimmapserialAsString
'worksheetname=InputBox("pleaseentertheworksheetname:
")
multinum=Val(InputBox("请输入倍数:
"))
Ifmultinum=0Thenmultinum=1
mapserial=InputBox("请输入图纸号:
")
OnErrorResumeNext
Setappexcel=GetObject(,"excel.Application")
'如果错误,启动新的EXCEL实例
IfErrThen
Err.Clear
Setappexcel=CreateObject("excel.Application")
Setworkbooks=appexcel.workbooks
Setworkbook=workbooks.Add
Setworksheet=workbook.ActiveSheet
'如果EXCEL已经运行,关联用户输入的工作表
Else
Setworkbook=appexcel.ActiveWorkbook
Ifworksheetname=""Then
Setworksheet=workbook.ActiveSheet
Else
Setworksheet=workbook.Sheets(worksheetname)
EndIf
'如果工作表不存在,添加工作表
IfErrThen
Err.Clear
Setworksheet=workbook.Sheets.Add()
worksheet.Name=worksheetname
EndIf
EndIf
rowscount=worksheet.range("a1").CurrentRegion.rows.count
Dimselectcount,objectcount,i,j,k,m,N,yesnotablelineAsInteger
Dimresult,result1,controlpAsVariant
DimtextAsAcadText
DimentityAsAcadEntity
DimselectsAsAcadSelectionSet
DimrestrictpAsNewCollection
ThisDrawing.SelectionSets.Item("r").Delete
IfErrThen
Setselects=ThisDrawing.SelectionSets.Add("r")
Err.Clear
EndIf
'definefilter
DimgpCode(0)AsInteger
DimdataValue(0)AsVariant
DimgroupCodeAsVariant,dataCodeAsVariant
gpCode(0)=0
dataValue(0)="text"
groupCode=gpCode
dataCode=dataValue
DimjudgeselectpAsInteger
DimpointarrayAsVariant
DimtablescaleAsDouble
'tablescale=ThisDrawing.Utility.GetReal("pleaseenterthetablescale")
tablescale=25
Iftablescale=0Thentablescale=1
pointarray=Array(0,11.82,71.82,81.82,94.82,111.82,126.82,141.82,179.85)
judgeselectp=0
Ifjudgeselectp=1Then
OnErrorGoToerrorhandle
DoWhileNotErr
controlp=ThisDrawing.Utility.GetPoint(,"选择点:
")
restrictp.Addcontrolp(0)
Loop
Else
controlp=ThisDrawing.Utility.GetPoint(,"选择点:
")
restrictp.Addcontrolp(0)+pointarray(0)*tablescale
Fori=1ToUBound(pointarray)
restrictp.Addcontrolp(0)+pointarray(i)*tablescale
Nexti
EndIf
'EndSelect
errorhandle:
'MsgBox"ok?
"
OnErrorResumeNext
ThisDrawing.Utility.Prompt"请选择所要转换的文本"
selects.SelectOnScreengroupCode,dataCode
objectcount=selects.count
DimcolectionobjAsNewCollection
DimcolectionxtAsNewCollection
DimcolectionxAsNewCollection
DimcolectionyAsNewCollection
DimcolectionxbAsNewCollection
DimcolectionxfAsNewCollection
DimtextheightAsDouble
DimmaxrownumAsInteger
DimsortAsNewCollection
Dimp1,p2,p3,p4
textheight=selects
(1).height
ForEachtextInselects
colectionobj.Addtext
Nexttext
selects.Delete
Setsort=Sort2(colectionobj,textheight)
Dimkkk1,kkk2AsDouble
Fori=1Tosort.count
Form=1Torestrictp.count-1
ForEachjInsort(i)
p2=j.InsertionPoint
kkk1=restrictp(m)
kkk2=restrictp(m+1)
Ifrestrictp(m) IfNotworksheet.Cells(i,m)=""Then worksheet.Cells(i+rowscount,m)=worksheet.Cells(i+rowscount,m)&""&j.TextString Else worksheet.Cells(i+rowscount,m)=j.TextString EndIf EndIf Nextj Nextm worksheet.Cells(i+rowscount,9)=multinum workshe
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- CAD 文字 提取 EXCEL 表格