Excel VBA以选择多段线并将区域带回Excel
有没有一个excel vba，如果我按下一个按钮，它将进入autocad会话，我将选择一条折线，然后将值报告回我开始的excel电子表格？(面积，z等。)?**** Hidden Message ***** 选项明确
Sub PickLwPolyAndGetData()
Dim MyCell As Range
Dim ACAD As AcadApplication
Dim LWPoly As AcadLWPolyline
Dim ThisDrawing As AcadDocument
Dim Pt1 As Variant
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' select LwPolyline
On Error Resume Next
Do
Err.Clear
ThisDrawing.Utility.GetEntity LWPoly, Pt1, "Select a Polyline:"
Loop While Err
On Error GoTo 0
'get LWPoly data
With LWPoly
LWArea = .Area
LWZ = .Elevation
End With
' write LWPoly data on worksheet
Set MyCell = ActiveCell
With MyCell
.Offset(0, 0).Value = "Area:"
.Offset(0, 1).Value = LWArea
.Offset(1, 0) = "Z:"
.Offset(1, 0) = LWZ
End With
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
再见 这样很酷。我可以让用户一次选择一组多段线吗？ 如果你不介意的话，我可以举个例子吗？你所做的是一块巨大的垫脚石
我们有一些多段线，其中包含需要放入电子表格的区域 试试这个
Sub PickLwPolysAndGetData()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(1, 1)
With MyCell
.Offset(0, 0).Value = "LWPoly nr"
.Offset(0, 1).Value = "Area"
.Offset(0, 2) = "Z"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each LWPoly In ssetObj
'retrieving LWPoly data
With LWPoly
LWArea = .Area
LWZ = .Elevation
End With
' writing LWPoly data
With MyCell
.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWArea
.Offset(iRow, 2) = LWZ
End With
iRow = iRow + 1
Next LWPoly
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
再见 直接在excel中通过一些求和的方式完成这项工作要简单得多。IF函数，该函数读取C列值（“Z”值）并对相应的B列值（“面积”值）求和 井。我升级到了下一个 cad 版本！无论如何，现在当我运行我的宏时，我得到一个错误
运行时'13'：
类型不匹配
调试：
For Each LWPoly In ssetObj
任何帮助都会很棒！它在以前的cad版本中确实有效。
Sub Import_POLYLINES()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
With MyCell
'.Offset(0, 0).Value = "LWPoly nr"
'.Offset(0, 1).Value = "Area S.F."
'.Offset(0, 0) = "Elevation"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each LWPoly In ssetObj
'retrieving LWPoly data
With LWPoly
LWArea = .area
LWZ = .Elevation
End With
' writing LWPoly data
With MyCell
'.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWArea
.Offset(iRow, 0) = LWZ
End With
iRow = iRow + 1
Next LWPoly
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
而不是:
对于ssetObj中的每个LWPoly...
使用方式:
Dim oEnt as acadentity
对于ssetObj中的每个ent
如果oEnt的类型是AcadLWpolyline，则
设置LWPoly=ent
...
“折线的一些剩余工作
结束，如果
下一个
类似这样的事情，只是从内存中 非常感谢。我明天会看看能不能让它工作。我会让你知道我的结果！ 好吧，我试过了，但在同一个地方我仍然得到同样的错误…奇怪。你看到什么不正确的地方了吗
Sub Import_POLYLINES()
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As range
'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim oEnt As AcadEntity
' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double
' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument
' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetObj.Clear
'setting filtering critera
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"
'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue
' processing LWPolylines
If ssetObj.Count > 0 Then
' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
With MyCell
'.Offset(0, 0).Value = "LWPoly nr"
'.Offset(0, 1).Value = "Area S.F."
'.Offset(0, 0) = "Elevation"
End With
'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each oEnt In ssetObj
If TypeOf oEnt Is AcadLWPolyline Then
Set LWPoly = oEnt
'retrieving LWPoly data
With LWPoly
LWArea = .area
LWZ = .Elevation
End With
' writing LWPoly data
With MyCell
'.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWArea
.Offset(iRow, 0) = LWZ
End With
iRow = iRow + 1
End If
Next oEnt
End If
' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing
End Sub
页:
[1]
2