乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
楼主: mstg007

Excel VBA选择多段线并将区域带回Excel

[复制链接]

238

主题

769

帖子

33

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1721
发表于 2014-4-16 21:45:19 | 显示全部楼层
非常感谢你。我看看明天能不能把这件事做好。我会让你知道我的结果!
回复

使用道具 举报

12

主题

175

帖子

77

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
149
发表于 2014-4-17 09:21:28 | 显示全部楼层
嗯,我试过了,但我仍然在同一个位置遇到同样的错误……奇怪。你看到什么不正确的地方了吗
  1. Sub Import_POLYLINES()
  2.    
  3.    
  4. 'for Excel sheet managing purposes
  5. Dim MySht As Worksheet
  6. Dim MyCell As range
  7. 'for Autocad application managing purposes
  8. Dim ACAD As AcadApplication
  9. Dim ThisDrawing As AcadDocument
  10. Dim LWPoly As AcadLWPolyline
  11. Dim oEnt As AcadEntity
  12. ' for selection set purposes
  13. Dim ssetObj As AcadSelectionSet
  14. Dim gpCode(0) As Integer
  15. Dim dataValue(0) As Variant
  16. 'for general variables managing purposes
  17. Dim iRow As Long
  18. Dim LWArea As Double, LWZ As Double
  19. ' Autocad Session handling
  20.     On Error Resume Next
  21.     Set ACAD = GetObject(, "AutoCAD.Application")
  22.     On Error GoTo 0
  23.     If ACAD Is Nothing Then
  24.         Set ACAD = New AcadApplication
  25.         ACAD.Visible = True
  26.     End If
  27.     Set ThisDrawing = ACAD.ActiveDocument
  28.       
  29. ' selecting LwPolylines on screen by selelection set filtering method
  30.     ' managing potential selection set exsistence
  31.     On Error Resume Next
  32.     Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
  33.     If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
  34.     On Error GoTo 0
  35.     ssetObj.Clear
  36.    
  37.     'setting filtering critera
  38.     gpCode(0) = 0
  39.     dataValue(0) = "LWPOLYLINE"
  40.    
  41.     'selecting LWPolylines
  42.     ssetObj.SelectOnScreen gpCode, dataValue
  43. ' processing LWPolylines
  44.     If ssetObj.Count > 0 Then
  45.    
  46.         ' writing sheet headings
  47.         Set MySht = ActiveSheet
  48.         Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
  49.         With MyCell
  50.             '.Offset(0, 0).Value = "LWPoly nr"
  51.             '.Offset(0, 1).Value = "Area S.F."
  52.             '.Offset(0, 0) = "Elevation"
  53.         End With
  54.         
  55.         'clearing previous written data
  56.         iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
  57.         If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
  58.         
  59.         'retrieving LWPolys data and writing them on worksheet
  60.         iRow = 1
  61.         For Each oEnt In ssetObj
  62.         If TypeOf oEnt Is AcadLWPolyline Then
  63.         Set LWPoly = oEnt
  64.       
  65.             'retrieving LWPoly data
  66.             With LWPoly
  67.                 LWArea = .area
  68.                 LWZ = .Elevation
  69.             End With
  70.             
  71.              ' writing LWPoly data
  72.             With MyCell
  73.                 '.Offset(iRow, 0).Value = "LWPoly nr." & iRow
  74.                 .Offset(iRow, 1).Value = LWArea
  75.                 .Offset(iRow, 0) = LWZ
  76.             End With
  77.             iRow = iRow + 1
  78.             
  79.             End If
  80.       
  81.        Next oEnt
  82.         
  83.    End If
  84. ' cleaning up before ending
  85.     ssetObj.Delete
  86.     Set ssetObj = Nothing
  87.     Set ThisDrawing = Nothing
  88.     Set ACAD = Nothing
  89. End Sub
回复

使用道具 举报

238

主题

769

帖子

33

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1721
发表于 2014-4-17 17:52:30 | 显示全部楼层
它可以编译吗?
回复

使用道具 举报

12

主题

175

帖子

77

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
149
发表于 2014-4-18 07:15:54 | 显示全部楼层
是的,它确实可以编译。如果调试器出现,我可以完成宏。据我所知,它在2013年没有出现任何问题。但自从我们升级到2014年,它就出现了。我所有的参考资料也都更新了。我有一个包裹宏,我做了更新,并与2014年的工作(缓慢)。我只是不能得到这个多段线了。
回复

使用道具 举报

12

主题

175

帖子

77

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
149
发表于 2014-4-18 07:54:58 | 显示全部楼层
如果你把图纸发给我,我可以看一看。但在Acad2010中,无论如何,它可能会对你有用。
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-4-20 18:08 , Processed in 1.256957 second(s), 71 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表