社区 › VB › [原创]Auto CAD材料一览表数据到Excel

兰州人 发表于 2007-11-27 16:28:00

[原创]Auto CAD材料一览表数据到Excel

图示材料一览表是绘制施工图最常见表现形式。有人用属性块的方法处理方法见AutoCAD vba 二次开发第317页。
但在实际操作过程中，材料表的数据是任意方法写的，如
idInsertTextInsertPointXInsertPointY21283572245-322.418415478249.499999721283572401.2138.8666674217.499999721283572480.037127.4444451217.499999721283572568111.8622229217.499999721283572643695.00888957217.49999972128357272螺母M1643.50000068217.49999972128357280GB6170-8617.04704513217.4999997212835728807RH09-0415.76704513161.4999997212835729607RH09-0615.76704513153.4999997212835730407RH09-0615.76704513129.4999997212835737607RH09-0415.7670451357.49999969212835738407RH09-0515.7670451349.49999969212835739207RH09-0515.7670451341.4999996921283574005-302.418415478233.4999997
hadle,x,y数据是无序排序。
要实现以下目标，需要进行SQL+数组排序处理。
5-107RH09-03固定管板I116Mn/0Cr18Ni10Ti　914.5其中不锈钢66.5kg5-3GB9948.SHJ405接管 DN20 Sch802200.20.4L=108

zhouzhiy 发表于 2017-11-8 18:02:00

谢谢楼主分享！

兰州人 发表于 2007-11-27 16:35:00

SQL+mdb处理方法
' 从数据库中读取数据
Sub ReadFromMdbFile()
    ' 创建数据库连接
    Dim YCount, nn As Integer
    Dim XDistinct, YDistinct
    Call CreateConnection
    Dim rst As ADODB.Recordset, ii As Integer
    ' 在line表中查询所有的记录
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseClient
'Distinct Y 统计Y坐标的不重复数量
    rst.Open "SELECT val(format(InsertPointY,'0.00')) FROM EntityText" & _
         " Group By val(Format(InsertPointY,'0.00'))" & _
         " Order By val(Format(InsertPointY,'0.00'))" & _
         "", cn, adOpenForwardOnly, _
            adLockBatchOptimistic, adCmdText
    rst.MoveFirst
    ReDim YDistinct(rst.RecordCount - 1)
    For ii = 0 To rst.RecordCount - 1
      YDistinct(ii) = rst.Fields(0).Value
      Debug.Print YDistinct(ii)
      rst.MoveNext
    Next ii
    rst.Close
1.5
9.5
17.5
25.5
33.5
41.5
49.5
57.5
65.5
73.5
81.5
89.5
97.5
'Distinct X 统计X坐标的不重复数据的数量
    rst.Open "SELECT val(format(InsertPointX,'0')) FROM EntityText" & _
         " WhereFormat(InsertPointY,'0.00') = " & YDistinct(0) & _
         "", cn, adOpenForwardOnly, _
            adLockBatchOptimistic, adCmdText
    rst.MoveFirst
    ReDim XDistinct(rst.RecordCount - 1)
    For ii = 0 To rst.RecordCount - 1
      XDistinct(ii) = rst.Fields(0).Value
      Debug.Print XDistinct(ii)
      rst.MoveNext
    Next ii
    rst.Close
运行结果8列数的X坐标范围。
3
16
44
96
102
137
148
End Sub
相关的ADO帮助文件.
ADO.rar
2008-7-23
Sub ExcelToCadTable()
ThisDrawing.ActiveTextStyle.fontFile = "c:\windows\fonts\SIMHEI.ttf"
Dim colArray, rowBaseData
colArray = Array(404.55, 424, 455.11, 499, 510.11, 540.11, 550.69, 561.64)
rowBaseData = 84.71 - 6 - 8
Dim objText As AcadText
Dim xlSheet1
Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, alignmentPoint(0 To 2) As Double
Set xlSheet1 = ConnectExcel("Sheet1")
For ii = 40 To 1 Step -1
    For jj = 0 To UBound(colArray) - 1
      pp(0) = colArray(jj) + 2
      pp(1) = rowBaseData + 8
      tt = xlSheet1.Cells(ii, jj + 1)
      Select Case jj
      Case 5, 6
          If Val(tt)0 Then
            tt = "0" & tt
          End If
      End Select
      Set objText = ThisDrawing.ModelSpace.AddText(tt, pp, 4)
      alignmentPoint(1) = pp(1)
      Select Case jj
      Case 2, 7
          alignmentPoint(0) = colArray(jj) + 2
          objText.Alignment = acAlignmentLeft
          'objText.TextAlignmentPoint = alignmentPoint
      Case Else
          alignmentPoint(0) = colArray(jj) + (colArray(jj + 1) - colArray(jj)) / 2
          objText.Alignment = acAlignmentCenter
          objText.TextAlignmentPoint = alignmentPoint
      End Select
      '
    Next jj
    rowBaseData = rowBaseData + 8
Next ii
End Sub

兰州人 发表于 2007-11-28 08:44:00

AutoCAD2006以上版本使用属性块的方法如下
' 导出到Word中
Public Sub OutputToWord(ByVal SSetObj As AcadSelectionSet, ByVal LBObj As ListBox)
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdTable As Word.Table
   
    Dim EntObj As AcadEntity
    Dim AttRefObjs As Variant
    Dim n As Integer
    Dim i As Integer
    Dim j As Integer
   
    On Error Resume Next
    ' 连接Word
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
      Err.Clear
      Set wdApp = CreateObject("Word.Application")
      If Err Then
            Err.Clear
            MsgBox "无法启动Word，请检查是否正确安装！"
            Exit Sub
      End If
    End If
    wdApp.Visible = True
   
    On Error GoTo ErrTrap
    ' 返回新创建的文档
    Set wdDoc = wdApp.Documents.Add
    ' 返回在段落一之后新创建的表格
    Set wdTable = wdDoc.Tables.Add(wdDoc.Paragraphs(1).Range, 1, LBObj.ListCount)
   
    n = 0
    ' 遍历选择集
    For Each EntObj In SSetObj
      ' 增加行
      wdTable.Rows.Add
      ' 返回属性数据
      AttRefObjs = EntObj.GetAttributes
      n = n + 1
      For i = 0 To UBound(AttRefObjs)
            For j = 0 To LBObj.ListCount - 1
                If AttRefObjs(i).TagString = LBObj.List(j) And LBObj.Selected(j) = True Then
                  If n = 1 Then
                        ' 首行，标签做为表格的列标题
                        wdTable.Cell(n, j + 1).Range.Text = AttRefObjs(i).TagString
                        wdTable.Cell(n + 1, j + 1).Range.Text = AttRefObjs(i).TextString
                  Else
                        wdTable.Cell(n + 1, j + 1).Range.Text = AttRefObjs(i).TextString
                  End If
                End If
            Next
      Next
    Next
   
    ' 删除表格中的空列
    For i = LBObj.ListCount - 1 To 0 Step -1
      If wdTable.Cell(1, i + 1).Range.Text = vbCr + Chr(7) Then
            wdTable.Columns(i + 1).Delete
      End If
    Next
   
    ' 按序号排序
    wdTable.Sort True, "列 1"
    ' 自动调整列宽
    wdTable.AutoFitBehavior 1
   
    ' 释放Word对象
    Set wdTable = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
   
ErrTrap:
    On Error GoTo 0
End Sub
' 导出到Excel中
Public Sub OutputToExcel(ByVal SSetObj As AcadSelectionSet, ByVal LBObj As ListBox)
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
   
    Dim EntObj As AcadEntity
    Dim AttRefObjs As Variant
    Dim n As Integer
    Dim i As Integer
    Dim j As Integer
   
    On Error Resume Next
    ' 连接Excel
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
      Err.Clear
      Set xlApp = CreateObject("Excel.Application")
      If Err Then
            Err.Clear
            MsgBox "无法启动Word，请检查是否正确安装！"
            Exit Sub
      End If
    End If
    xlApp.Visible = True
   
    On Error GoTo ErrTrap
    ' 返回新创建的工作簿
    Set xlBook = xlApp.Workbooks.Add
    ' 返回新增加的工作表，并移动到最后一个
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Move , xlBook.Worksheets(xlBook.Worksheets.Count)
   
    n = 0
    ' 遍历选择集
    For Each EntObj In SSetObj
      ' 返回属性数据
      AttRefObjs = EntObj.GetAttributes
      n = n + 1
      For i = 0 To UBound(AttRefObjs)
            For j = 0 To LBObj.ListCount - 1
                If AttRefObjs(i).TagString = LBObj.List(j) And LBObj.Selected(j) = True Then
                  If n = 1 Then
                        ' 首行，标签做为表格的列标题
                        xlSheet.Cells(n, j + 1).Value = AttRefObjs(i).TagString
                        xlSheet.Cells(n + 1, j + 1).Value = AttRefObjs(i).TextString
                  Else
                        xlSheet.Cells(n + 1, j + 1).Value = AttRefObjs(i).TextString
                  End If
                End If
            Next
      Next
    Next
   
    ' 删除表格中的空列
    For i = LBObj.ListCount - 1 To 0 Step -1
      If xlSheet.Cells(1, i + 1).Value = "" Then
            xlSheet.Columns(i + 1).Delete
      End If
    Next
   
    ' 按序号排序
    xlSheet.UsedRange.Sort Key1:=Range("A2"), Header:=xlYes
    ' 自动调整列宽
    xlSheet.Columns.AutoFit
    ' 释放Exccel对象
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Exit Sub
   
ErrTrap:
    On Error GoTo 0
End Sub
Excel VBA 范例文件代码
Excel VBA 范例文件代码.rar

兰州人 发表于 2007-12-5 15:43:00

select选择集+图层Layer
Sub ls()
Dim ss1 As AcadSelectionSet
Dim layername As String
Dim AcadEnt As AcadEntity
'Dim pp1 As AcadPoint, pp2 As AcadPoint
'指定图层名称
'Set pp1 = ThisDrawing.Utility.GetPoint
'Set pp2 = ThisDrawing.Utility.GetPoint
layername = "件号"
Dim tt As AcadText, MTt As AcadMText
'得到选择集
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 8
dataValue(0) = layername
Set ss1 = ThisDrawing.SelectionSets.Add("ss3")
ss1.Select acSelectionSetAll, , , gpCode, dataValue
'ss1.Select acSelectionSetCrossing, pp1, pp2, , dataValue
For Each AcadEnt In ss1
'Debug.Print AcadEnt.ObjectName
Select Case AcadEnt.ObjectName
    Case "AcDbText"
      Set tt = AcadEnt
      Debug.Print tt.TextString
    Case "AcDbMText"
      Set MTt = AcadEnt
      Debug.Print "MText---", MTt.TextString
End Select
Next
ss1.Delete
'ss1.Clear
End Sub

muzi2005888 发表于 2007-12-30 16:32:00

支持兰州人！

zy19860604 发表于 2008-1-13 12:32:00

好资料

sooma 发表于 2008-1-31 22:46:00

高人阿！谢谢

sunny2008 发表于 2008-2-25 19:01:00

收获了很多资料

ecepdiky 发表于 2008-4-2 20:36:00

本人前不久也刚刚编写了一个cad表格自动输出到EXCEL的vba代码,基本思路就是把选择到的所有文字实体先按y坐标排序,由此可以把这些字分成若干行,每行再按纵坐标排序,确定先后顺序,缺点就是无法判断空的单元格,会导致后面的单元格内容串列.

查看完整版本: [原创]Auto CAD材料一览表数据到Excel