用数组的形式统计直线长度到EXCEL一个单元格中

jsxygshh

请各位帮忙解决，下面的VBA代码如何修改，才可以让选择的直线或多线长度统计到EXCEL的一个单元格内，各长度进行累加，显示长度计算式，先谢谢

2. Public Sub getlength() '统计长度
   
3. Set acadApp = GetObject(, "AutoCAD.Application")
   
4. Set Xlapp = GetObject(, "Excel.Application")
   
5.     Dim entry As AcadEntity, hjx As Variant, FType(0) As Integer, FData(0) As Variant, sjx As AcadSelectionSet, i As Long
   
6.     FType(0) = 0
   
7.     FData(0) = "Length"
   
8.     On Error Resume Next
   
9.     ThisDrawing.SelectionSets.Item("sf").Delete
   
10.     Set sjx = acadApp.ActiveDocument.SelectionSets.Add("sf")
    
11.     sjx.SelectOnScreen
    
12.     h = sjx.Count
    
13.     sjx.Select acSelectionSetAll, , , FType, FData
    
14.     With Xlapp
    
15.         k = .ActiveCell.row
    
16.         j = .ActiveCell.Column
    
17.         For Each entry In sjx
    
18.             hjx = entry.Length
    
19.             .cells(k, j) = Format(hjx / 1000, "##0.00")
    
20.             k = k + 1
    
21.             .cells(k, j).Activate
    
22.         Next entry
    
23.     End With
    
24.     sjx.Delete
    
25. End Sub

Public Sub getlength() '统计长度<br /> Set acadApp = GetObject(, "<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.Application")<br /> Set Xlapp = GetObject(, "Excel.Application")<br />     Dim entry As AcadEntity, hjx As Variant, FType(0) As Integer, FData(0) As Variant, sjx As AcadSelectionSet, i As Long<br />     FType(0) = 0<br />     FData(0) = "Length"<br />     On Error Resume Next<br />     ThisDrawing.SelectionSets.Item("sf").Delete<br />     Set sjx = acadApp.ActiveDocument.SelectionSets.Add("sf")<br />     sjx.SelectOnScreen<br />     h = sjx.Count<br />     sjx.Select acSelectionSetAll, , , FType, FData<br />     With Xlapp<br />         k = .ActiveCell.row<br />         j = .ActiveCell.Column<br />         For Each entry In sjx<br />             hjx = entry.Length<br />             .cells(k, j) = Format(hjx / 1000, "##0.00")<br />             k = k + 1<br />             .cells(k, j).Activate<br />         Next entry<br />     End With<br />     sjx.Delete<br /> End Sub

vbcad

1. 
   
2.     With Xlapp
   
3.         k = .ActiveCell.row '电子表格中当前单元格的 行号
   
4.         j = .ActiveCell.Column'当前单元格的 列号
   
5.         For Each entry In sjx
   
6.             hjx = entry.Length'获得长度
   
7.             .cells(k, j) = Format(hjx / 1000, "##0.00")'在单元格（k行，j列）中写入长度（除以1000），显示两位小数
   
8.             k = k + 1'累加行号
   
9.             .cells(k, j).Activate'将单元格（k行，j列）置为当前
   
10.         Next entry
    
11.     End With
    

复制代码

从上面可以看出，取得一个图形元素的长度，单元格就会递增（累加）一行。
如果只想写入一个单元格内，则按下面的代码

1. 
   
2. dim tmpStr as string
   
3. 
   
4.     With Xlapp
   
5.         k = .ActiveCell.row '电子表格中当前单元格的 行号
   
6.         j = .ActiveCell.Column'当前单元格的 列号
   
7.         For Each entry In sjx
   
8.             hjx = entry.Length'获得长度
   
9. hj=hj+hjx'累加线段长度
   
10. tmpStr =tmpStr  &"  "& str(hjx )'将长度转换为字符，保存长度
    
11. 
    
12.         Next entry
    
13. .cells(k, j) =tmpStr '所有线段的长度空格隔开放在一个单元格中
    
14. .cells(k+1, j) =hj'在下一行中写入所有线段的长度和
    
15.     End With
    

复制代码

jsxygshh

谢谢vbcad的帮助，调试成功了，十分感谢！

vbcad

jsxygshh 发表于 2014-2-10 20:20
谢谢vbcad的帮助，调试成功了，十分感谢！