1、工具-加载应用程序”选择文件夹中的 tbl.fas命令行提示：已成功加载 tbl.fas3、命令行输入：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.
2、rar提取cad表格到excel,源码公开 本程序是本人接触cad以来一直在做的东东，不断的完善，当我程序的功能还不满意的时候,一直在网上找truetable这个软件，对里面的变编程原理非常感兴趣，现在随着在名经通道得到efan2000,lzh741206斑竹的帮助，终于实现了自己的程序功能，愿公布自己的源码，使很多象我一样对原理感兴趣的朋友心中释然，并在实际的工作中随心所欲编写出满足自己要求的程序，本程序设定了两个控制变量，根据变量的值确定程序的执行路线，tablescale确定当采用固定表格格式时，表格的比例judgeselectp的取值决定用户决定是自己选择点还是采用固定的表格格式还有一
3、直形式就是在用户选择了所要转换的文字时，完全智能化，这样的功能我在microstation vba的编程中已经实现，在本程序的基础上实现也相当容易，但考虑到这种方法没有什么实际的意义，所以在cad里面没有做这个工作,希望对大家有帮助！Option ExplicitPublic Sub bestt（）link excelDim appexcel As Excel.ApplicationDim worksheets As Excel.worksheetsDim workbooks As Excel.workbooksDim workbook As Excel.workbookDim workshe
4、et As Excel.worksheetDim worksheetname As StringDim rowscount As IntegerDim porline As IntegerDim multinum As IntegerDim mapserial As Stringworksheetname = InputBox（please enter the worksheetname:multinum = Val（InputBox（请输入倍数:）If multinum = 0 Then multinum = 1mapserial = InputBox（请输入图纸号:On Error Res
5、ume NextSet appexcel = GetObject（, excel.Application如果错误，启动新的EXCEL实例If Err ThenErr.ClearSet appexcel = CreateObject（Set workbooks = appexcel.workbooksSet workbook = workbooks.AddSet worksheet = workbook.ActiveSheet如果EXCEL已经运行，关联用户输入的工作表ElseSet workbook = appexcel.ActiveWorkbookIf worksheetname = The
6、nSet worksheet = workbook.Sheets（worksheetname）End If如果工作表不存在，添加工作表Set worksheet = workbook.Sheets.Add（）worksheet.Name = worksheetnamerowscount = worksheet.range（a1）.CurrentRegion.rows.countDim selectcount, objectcount, i, j, k, m, N, yesnotableline As IntegerDim result, result1, controlp As Variant
7、Dim text As AcadTextDim entity As AcadEntityDim selects As AcadSelectionSetDim restrictp As New CollectionThisDrawing.SelectionSets.Item（r）.DeleteSet selects = ThisDrawing.SelectionSets.Add（define filterDim gpCode（0） As IntegerDim dataValue（0） As VariantDim groupCode As Variant, dataCode As Variantg
8、pCode（0） = 0dataValue（0） = textgroupCode = gpCodedataCode = dataValueDim judgeselectp As IntegerDim pointarray As VariantDim tablescale As Doubletablescale = ThisDrawing.Utility.GetReal（please enter the table scaletablescale = 25If tablescale = 0 Then tablescale = 1pointarray = Array（0, 11.82, 71.82
9、, 81.82, 94.82, 111.82, 126.82, 141.82, 179.85）judgeselectp = 0If judgeselectp = 1 ThenOn Error GoTo errorhandleDo While Not Errcontrolp = ThisDrawing.Utility.GetPoint（, 选择点:restrictp.Add controlp（0）Looprestrictp.Add controlp（0） + pointarray（0） * tablescaleFor i = 1 To UBound（pointarray）restrictp.Ad
10、d controlp（0） + pointarray（i） * tablescaleNext iEnd Selecterrorhandle:MsgBox ok?ThisDrawing.Utility.Prompt 请选择所要转换的文本selects.SelectOnScreen groupCode, dataCodeobjectcount = selects.countDim colectionobj As New CollectionDim colectionxt As New CollectionDim colectionx As New CollectionDim colectiony
11、As New CollectionDim colectionxb As New CollectionDim colectionxf As New CollectionDim textheight As DoubleDim maxrownum As IntegerDim sort As New CollectionDim p1, p2, p3, p4textheight = selects（1）.heightFor Each text In selectscolectionobj.Add textNext textselects.DeleteSet sort = Sort2（colectiono
12、bj, textheight）Dim kkk1, kkk2 As DoubleFor i = 1 To sort.countFor m = 1 To restrictp.count - 1For Each j In sort（i）p2 = j.InsertionPointkkk1 = restrictp（m）kkk2 = restrictp（m + 1）If restrictp（m） p2（0） And p2（0） restrictp（m + 1） ThenIf Not worksheet.Cells（i, m） = worksheet.Cells（i + rowscount, m） = worksheet.Cells（i + rowscount, m） & & j.TextStringworksheet.Cells（i + rowscount, m） = j.TextStringNext jNext mworksheet.Cells（i + rowscount, 9） = multinumworkshe
