原创力文档- 1、本文档共12页，可阅读全部内容。
- 2、原创力文档（book118）网站文档一经付费（服务费），不意味着购买了该文档的版权，仅供个人/单位学习、研究之用，不得用于商业用途，未经授权，严禁复制、发行、汇编、翻译或者网络传播等，侵权必究。
- 3、本站所有内容均由合作方或网友上传，本站不对文档的完整性、权威性及其观点立场正确性做任何保证或承诺！文档内容仅供研究参考，付费前请自行鉴别。如您付费，意味着您自己接受本站规则且自行承担风险，本站不退款、不进行额外附加服务；查看《如何避免下载的几个坑》。如果您已付费下载过本站文档，您可以点击 这里二次下载。
- 4、如文档侵犯商业秘密、侵犯著作权、侵犯人身权等，请点击“版权申诉”（推荐），也可以打举报电话：400-050-0827(电话支持时间：9:00-18:30)。
查看更多
CAD文字提取到EXCEL表格
天工作时碰到一个问题，在接到的某个cad图纸中，作者制作了材料表，见下图 该作者制作该表时，是画了直线和用多行文字，并没有用到cad的表格功能，或者链接excel的表格（这样作表格十分辛苦呢，呵呵） 但是我又恰恰要用到这个表格的数据，本人一向很懒，本来这么点东西直接重新照着在excel里打一次也用不了多少时间，可是我想有没有什么办法能直接提取这些文字出来呢，省得打了，最开始我就用了我一向喜欢的CAjViewer 7.0 ，之前统计xsbf老师图片上的文字就是用它，CAjViewer 7.0有汉字识别系统，能将图片上的文字识别为文本文字，于是截图，转换为pdf文件，用CAjViewer 7.0打开，文字识别，结果效果不理想，全是乱码。 于是上网查找，终于找到一个工具可以实现，工具的来源请看标题 效果如下 [ 本帖最后由 truezx 于 2008-10-15 16:31 编辑 ]
CAD文字提取到EXCEL表格 将CAD中表格中文字(单行文字,多行文字应炸开)按坐标位置关系提取到EXCEL中的程序如下 (LOAD "TBL") TXTTBL 工具的使用方法如下： 1、选择你要复制的所有文字（可以用快速选择），然后点击分解，炸开这些文字 2、cad中打开"工具"----"加载应用程序”－－－－选择文件夹中的 tbl.fas 命令行提示：已成功加载 tbl.fas 3、命令行输入：txttbl 然后命令行提示： scliukejun QQ:303810,三维网 2007年6月 选择对象: 框选你要复制的文字 4、确认后，提示你是要保存，还是打开，选择打开后就是一楼第二张图片的效果了（具体界面看三楼的图）。 [ 本帖最后由 truezx 于 2008-10-15 11:37 编辑 ]
tbl.rar
作者: truezx??发布日期: 2008-10-15
另外一个工具，也是那个论坛完全转贴过来的 加载LISP (load "tbl") 运行用 tbl 点选一CAD表格图元,完后弹出一对话框, 选打开
tbl2.rar
提取cad表格到excel,源码公开
本程序是本人接触cad以来一直在做的东东，不断的完善，当我程序的功能还不满意的时候,一直在网上找truetable这个软件，对里面的变编程原理非常感兴趣，现在随着在名经通道得到efan2000,lzh741206斑竹的帮助，终于实现了自己的程序功能，愿公布自己的源码，使很多象我一样对原理感兴趣的朋友心中释然，并在实际的工作中随心所欲编写出满足自己要求的程序， 本程序设定了两个控制变量，根据变量的值确定程序的执行路线， tablescale确定当采用固定表格格式时，表格的比例 judgeselectp的取值决定用户决定是自己选择点还是采用固定的表格格式 还有一直形式就是在用户选择了所要转换的文字时，完全智能化，这样的功能我在microstation vba的编程中已经实现，在本程序的基础上实现也相当容易，但考虑到这种方法没有什么实际的意义，所以在cad里面没有做这个工作,希望对大家有帮助！ Option Explicit Public Sub bestt() 'link excel Dim appexcel As Excel.Application Dim worksheets As Excel.worksheets Dim workbooks As Excel.workbooks Dim workbook As Excel.workbook Dim worksheet As Excel.worksheet Dim worksheetname As String Dim rowscount As Integer Dim porline As Integer Dim multinum As Integer Dim mapserial As String 'worksheetname = InputBox("please enter the worksheetname:") multinum = Val(InputBox("请输入倍数:")) If multinum = 0 Then multinum = 1 mapserial = InputBox("请输入图纸号:") On Error Resume Next Set appexcel = GetObject(, "excel.Application") '如果错误，启动新的EXCEL实例 If Err Then Err.Clear
文档评论（0）