| CAD二次开发（VB）代码整理 | 您所在的位置：网站首页 › vbnet与vb › CAD二次开发（VB）代码整理 |
|
有时工作中在CAD上一笔一划设计图纸的重复动作，为了提高设计效率，我闲暇之余经常自己搞弄CAD二次开发，现在整理了一些平时项目中常用到的程序供大家参考使用，基本都是手打哦。 文章包含代码： CAD连通Excel数据 面积统计 图框替换 CAD连通Excel数据很多Excel中计算后的新成果需要与CAD上工程量、坐标信息等表格来回修改，数据都是有的，那么如何编写代码实现这一的粘贴复制呢？ 首先，编写将Excel表格导入CAD中显示为直线与文字的组合，其思路是：获得Excel中行数、列数及间距，按照相应比例绘制表格横竖线，然后读取Excel数据对应位置写入为CAD文字。 Sub E_cad() Dim mybook As Object Dim mySheet As Object Dim txt As String Dim name As String Set mybook = ExcelBookOpen("d:\l-hang.xlsx") For n = 1 To 19 Set mySheet = mybook.Sheets(n) colcount = mySheet.UsedRange.Columns.Count rowcount = mySheet.UsedRange.Rows.Count name = mySheet.cells(1, colcount) AcadText name, colcount * 8.5, -(n - 1) * 100 + 5, 5 For col = 1 To colcount - 1 ColsW = ColsW + mySheet.Columns(col).ColumnWidth '表格总列宽 Next RowsH = (rowcount - 1) * 4.7 + 9.4 '总高度 AcadLine 0, -(n - 1) * 100 - RowsH, RowsH, 90, acBlue '画初始竖线 AcadLine 0, -(n - 1) * 100 - RowsH, ColsW, 0, acBlue '画底部横线 For col = 1 To colcount - 1 ColW = mySheet.Columns(col).ColumnWidth '单列宽 For row = 1 To rowcount txt = mySheet.cells(row, col) If Len(txt) - Len(Replace(txt, ".", "")) >= 1 Then '控制小数点位 txt = Format(txt, "0.00") End If ORowsH = mySheet.Rows(row).RowHeight '单横高 If row = 1 Then AcadText txt, jColW + ColW / 2, -(n - 1) * 100 - ORowsH / 2, 3.5 ElseIf row > 1 Then AcadText txt, jColW+ColW/2, -(n - 1) * 100 - jRowH - ORowsH / 2, 3.5 End If If col = 1 And row = 1 Then AcadLine 0, -(n - 1) * 100, ColsW, 0, acBlue '画每行横线 ElseIf col = 1 And row > 1 Then AcadLine 0, -(n - 1) * 100 - 9.4 - (row - 2) * 4.7, ColsW, 0, acMagenta End If jRowH = jRowH + ORowsH Next jColW = jColW + ColW '累加列宽 jRowH = 0 If col = colcount - 1 Then '最后竖线 AcadLine jColW, -(n-1)*100 - RowsH, RowsH, 90, acBlue Else AcadLine jColW, -(n-1)*100 - RowsH, RowsH, 90, acMagenta '每列竖线 End If Next jRowH = 0 : jColW = 0 : ColsW = 0 Next End Sub Public Function ExcelBookOpen(FilePath As String) Dim o_Excel As Object Dim o_book As Object Set o_Excel = CreateObject("Excel.Application") '建立电子表格实例 o_Excel.Visible = True '设置可见 Set o_book = o_Excel.Workbooks.Open(FilePath, 0) '打开文件 Set ExcelBookOpen = o_book '返回对象 End Function Public Function AcadText(sText As String, X, y, h) ' 添加单行文字 Dim o_Text As Object Dim Location(0 To 2) As Double Location(0) = X Location(1) = y Set o_Text = ThisDrawing.ModelSpace.AddText(sText, Location, h) ' o_Text.Rotation = 0 '角度 o_Text.Alignment = 10 '对齐方式（正中） |
| CopyRight 2018-2019 实验室设备网 版权所有 |