[求助]请教efan老师？我前天发的贴子，可能太隐蔽了。不好意思重发一遍吧

HQ_2003 发表于 2003-6-2 19:00:00

我看了许多关于Cad与Excel相互连接的问题，大部分都是讲在Cad中提取块属性到Excel中，或者是把Excel表格提取到Cad中。

我现在想做的就是手动选择Cad中的材料表内容动态或是按一定路径输出到Excel中或者是文本文件中，而且输出的内容能按一定规则排序。
希望斑竹或其它高手能给出一些示例代码，谢了。

efan2000 发表于 2003-6-3 12:44:00

其实原理是一样的

将块属性导出到Excel，是先获取要导出的块的对象。而导出文字，可以先选择所需要的文字，然后对这样文字进行组织，比如放入到数组中，对数组中的文字排序，最后导出到Excel。
能上传一个附件吗？说明一下排序的方式。

HQ_2003 发表于 2003-6-7 20:04:00

不好！编辑贴子的时候不能编辑上传的文件，此贴子的文件重新上传吧.

本帖最后由作者于 2003-6-7 20:04:22 编辑

这方面的原理这两天我也研究了一下。心里也有了个模糊认识。但实际编起程序来总觉得不容易，只能东拼西凑的。最后一运行也总是出错，总觉得不专业。因此来麻烦尹凡老师(不知你的名字是否写对了,我好像在“晓东cad“网站上见过你的名字)
以下是cad做的构件明细表
程序要求：
1.按cad中的明细表格式输出到excel中(输出后最好能根据所选输出字体大小自动调整excel中列和行的宽度);
2.输出后以规格一列作为主要关键字，以备注一列作为次要关键字递减排序；
3.当选择明细表时如果没有全部选中，提示用户能继续窗选余下的内容，并顺序输入到同一个文件中。

[此贴子已经被作者于2003-6-7 19:56:13编辑过]

efan2000 发表于 2003-6-3 23:33:00

自己先尝试一遍吧，不明白的地方再提出来。

由于明细表不是块形式的，因而文字的处理就比较麻烦，究竟它属于哪一列哪一行的都要自己去处理。
先自己试着编写一下，也可以积累一些经验。

HQ_2003 发表于 2003-6-7 19:42:00

再次请教?(单位网络最近几天有问题，今天刚到。不知能否得到efan斑竹的指导）

我绞尽脑汁想了几天，最后只写了这样一些代码。唉！关键的问题还是没有解决--"按cad中的材料表格式输出",帮我提示一下吧！

HQ_2003 发表于 2003-6-7 20:06:00

文件上传

efan2000 发表于 2003-6-8 11:09:00

明细表中的实体为单行文字和直线

明细表中的实体全部是单行文字和直线，这种表格的输出是相对麻烦的，因为对于一个表格来说，应该知道文字所在的行和列，而这个最重要的因素却无法直接获取。
有两种方法解决，一是判断文字距明细表内容的左上角点之间，有几条水平直线和垂直直线，那么这个文字就确定了哪一行和哪一列。这要用到选择集，而选择集只能对窗口可视部分的实体操作，因而有可能会出现不可预料的结果，而且检查了一下，有的文字的插入点偏了位置，跑到另一列去了。
二是确定明细表每一行的行高和每一列到明细表内容的左下角点的列宽，然根据文字的插入点，求出文字所在的行和列。
最后输出到Excel，剩下的操作应该借助于Excel的功能来实现了。

efan2000 发表于 2003-6-8 11:15:00

这是部分代码，由于没有时间，还没完成。

Option Explicit

Dim iPt As Variant
Dim rh As Double
Dim cw() As Double

Sub test()
Dim xlApp As Object
Dim SSetObj As AcadSelectionSet
Dim fType(0 To 0) As Integer
Dim fData(0 To 0) As Variant
Dim EntObj As AcadEntity
Dim Pt As Variant

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
   Err.Clear
   Set xlApp = CreateObject("Excel.Application")
   xlApp.Visible = True
   xlApp.workbooks.Add
End If
Set SSetObj = ThisDrawing.SelectionSets("MXB")
If Err.Number <> 0 Then
   Err.Clear
   Set SSetObj = ThisDrawing.SelectionSets.Add("MXB")
End If
SSetObj.Clear

On Error GoTo ErrTrap
Dim xdType As Variant
Dim xdData As Variant
ThisDrawing.ModelSpace.GetXData "明细表表体", xdType, xdData
If IsEmpty(xdType) Then
   Pt = ThisDrawing.Utility.GetPoint(, "指定明细表内容的左上角点: ")
   ReDim xdType(0 To 1) As Integer
   ReDim xdData(0 To 1) As Variant
   xdType(0) = 1001
   xdData(0) = "明细表表体"
   xdType(1) = 1011
   xdData(1) = Pt
   ThisDrawing.ModelSpace.SetXData xdType, xdData
Else
   Pt = xdData(1)
End If
iPt = Pt
SetRow
SetColumn
fType(0) = 0: fData(0) = "Text"
SSetObj.SelectOnScreen fType, fData
Dim r As Integer
Dim c As Integer
For Each EntObj In SSetObj
   r = GetRow(EntObj)
   c = GetColumn(EntObj)
   If r > 0 And c > 0 Then xlApp.activesheet.cells(r, c) = EntObj.TextString
Next
Exit Sub

ErrTrap:
On Error GoTo 0
End Sub

Sub SetRow()
Dim xdType As Variant
Dim xdData As Variant
Dim Dist As Double

On Error GoTo ErrTrap
ThisDrawing.ModelSpace.GetXData "明细表行高", xdType, xdData
If IsEmpty(xdType) Then
   Dist = ThisDrawing.Utility.GetDistance(iPt, "指定明细表的行高: ")
   ReDim xdType(0 To 1) As Integer
   ReDim xdData(0 To 1) As Variant
   xdType(0) = 1001
   xdData(0) = "明细表行高"
   xdType(1) = 1040
   xdData(1) = Dist
   ThisDrawing.ModelSpace.SetXData xdType, xdData
Else
   Dist = xdData(1)
End If
rh = Dist
Exit Sub

ErrTrap:
On Error GoTo 0
End Sub

Sub SetColumn()
Dim xdType As Variant
Dim xdData As Variant
Dim n As Integer
Dim Dist As Double

On Error GoTo ErrTrap
ThisDrawing.ModelSpace.GetXData "明细表列宽", xdType, xdData
If IsEmpty(xdType) Then
   ReDim xdType(0 To 0) As Integer
   ReDim xdData(0 To 0) As Variant
   xdType(0) = 1001
   xdData(0) = "明细表列宽"
   Dist = -1
   Do While Dist <> 0
         Dist = ThisDrawing.Utility.GetDistance(iPt, "指定明细表的列宽: ")
         If Dist <> 0 Then
            n = n + 1
            ReDim Preserve xdType(0 To n) As Integer
            ReDim Preserve xdData(0 To n) As Variant
            xdType(n) = 1040
            xdData(n) = Dist
         End If
   Loop
   ThisDrawing.ModelSpace.SetXData xdType, xdData
End If
ReDim cw(0 To UBound(xdType) - 1)
For n = 1 To UBound(xdType)
   cw(n - 1) = xdData(n)
Next
Exit Sub

ErrTrap:
Dist = 0
Resume Next
On Error GoTo 0
End Sub

Function GetRow(ByVal EntObj As AcadText) As Integer
Dim tPt(0 To 2) As Double
Dim i As Integer
Dim n As Integer

On Error GoTo ErrTrap
tPt(0) = EntObj.InsertionPoint(0)
tPt(1) = EntObj.InsertionPoint(1) + 3
tPt(2) = 0
Do While iPt(1) + n * rh < tPt(1)
   n = n + 1
Loop
GetRow = n
Exit Function

ErrTrap:
On Error GoTo 0
End Function

Function GetColumn(ByVal EntObj As AcadText) As Integer
Dim tPt(0 To 2) As Double
Dim i As Integer
Dim n As Integer

On Error GoTo ErrTrap
tPt(0) = EntObj.InsertionPoint(0) + 5
tPt(1) = EntObj.InsertionPoint(1)
tPt(2) = 0
Do While iPt(0) + cw(n) < tPt(0)
   n = n + 1
Loop
GetColumn = n
Exit Function

ErrTrap:
On Error GoTo 0
End Function
其中，ipt保存了左下角点的坐标，rh保存了明细表的行高，cw数组保存了明细表的列宽（是指这一列与前面所有列的总宽度）。使用了扩展数据保存数据，因而上述的值只在第一次运行时会提示输入。
GetRow和GetColumn用于判断一个文字所在的行和列。
注意输出到Excel里的行顺序是倒着。

页: [1]

明经CAD社区's Archiver