自动导出挖填土方、桩号导出到excel表——cad vba实现

 

Sub mysel()
UserForm1.show
End Sub

 

Public Function creatsel() As AcadSelectionSet


On Error Resume Next
Dim mys As String
mys = "mys"
Dim sel As AcadSelectionSet
  If Not IsNull(ThisDrawing.SelectionSets.Item(mys)) Then
     Set creatsel = ThisDrawing.SelectionSets.Item(mys)
       creatsel.Delete
   End If
   'Set creatsel = ThisDrawing.SelectionSets.Add(mys)
End Function




Private Sub CommandButton5_Click()
Dim tcm1 As String
Dim tcm2 As String
Dim dx As Double
Dim dy As Double
Dim DZ As Double
tcm1 = "DMWF" '挖方 黄色
tcm2 = "DMTF" '"填方  绿色
dx = Val(TextBox3.Text)
dy = Val(TextBox4.Text)
DZ = Val(TextBox5.Text)
Dim sset As AcadSelectionSet '定义选择集对象
Dim A() As AcadText '桩号文字集
Dim B() As AcadText '挖方文字集
Dim C() As AcadText '填方文字集
Dim cselect As Boolean
cselect = False
Dim bselect As Boolean
bselect = False
Dim I As Integer
Dim j As Integer
Dim H As Integer
H = -1
I = -1
j = -1
Dim KX() As Double '桩号里程数组并纠正坐标到近似断面内
Dim KY() As Double
Dim KS() As String

Dim WX() As Double '挖方数组
Dim WY() As Double
Dim WS() As String

Dim TX() As Double '填方数组
Dim TY() As Double
Dim TS() As String

Dim element As AcadEntity '定义选择集中的元素对象


'On Error GoTo QQ   '出错陷井
  '安全创建选择集
        Do While ThisDrawing.SelectionSets.Count > 0
            ThisDrawing.SelectionSets.Item(0).Delete
        Loop
Set sset = ThisDrawing.SelectionSets.Add("SS") '新建一个选择集

UserForm1.Hide
sset.SelectOnScreen '提示用户选择

If sset.Count < 1 Then
Dim PX1 As Byte
PX1 = MsgBox("没有选中任何对象", 36, "NOTICE")
sset.Delete '删除选择集
End
End If
Dim XC As Double
For Each element In sset '在选择集中进行循环
'element.color = acGreen '改为绿色
    If element.Layer = "桩号" Then 'And element.color = acRed Then
      I = I + 1
      ReDim Preserve A(I), KX(I), KY(I), KS(I)
      Set A(I) = element
      KX(I) = Round(A(I).InsertionPoint(0), 3) + 7.4
      KY(I) = Round(A(I).InsertionPoint(1), 3)
      KS(I) = A(I).TextString
     ' MsgBox ("K:" & A(I).InsertionPoint(0) & ":" & A(I).InsertionPoint(1))
    End If
    If element.Layer = tcm1 Then   'And element.color = acYellow Then   挖方\
        bselect = True
        j = j + 1
        ReDim Preserve B(j), WX(j), WY(j), WS(j)
        If WS(j) = "" Then
           Set B(j) = element
           WX(j) = Round(B(j).InsertionPoint(0), 3)
           WY(j) = Round(B(j).InsertionPoint(1), 3)
           WS(j) = B(j).TextString
           ' MsgBox ("T:" & B(J).InsertionPoint(0) & ":" & B(J).InsertionPoint(1))
        Else
          ' MsgBox ("挖方问题")
        End If
   End If
  If element.Layer = tcm2 Then   'And element.color = acGreen   填方
  cselect = True
    H = H + 1
    ReDim Preserve C(H), TX(H), TY(H), TS(H)
      If TS(H) = "" Then
         Set C(H) = element
         TX(H) = Round(C(H).InsertionPoint(0), 3)
         TY(H) = Round(C(H).InsertionPoint(1), 3)
         TS(H) = C(H).TextString
          '    MsgBox ("T:" & C(H).InsertionPoint(0) & ":" & C(H).InsertionPoint(1)
     Else
          'MsgBox ("填方问题”")
     End If
  End If
Next
'假设选择到了需要的信息
Dim S1 As Double '填挖存储变量
Dim S2 As Double
Dim c1(0 To 2) As Double '四点坐标，画范围
Dim c2(0 To 2) As Double
Dim c3(0 To 2) As Double
Dim c4(0 To 2) As Double
For I = 0 To UBound(A)
    S1 = 0
    S2 = 0
   If cselect = False Then '如果没有选中填方
   Else
        For H = 0 To UBound(C)
            If (TY(H) - KY(I)) >= DZ And (TY(H) - KY(I)) <= dy And Abs(TX(H) - KX(I)) < dx Then
                S2 = S2 + Val(Mid(TS(H), InStr(TS(H), "=") + 1))
            End If
        Next H
   End If
    If bselect = False Then '如果没有选中挖方
'        ' MsgBox ("没有选中挖方")
    Else
            For j = 0 To UBound(B)
                If (WY(j) - KY(I)) >= DZ And (WY(j) - KY(I)) <= dy And Abs(WX(j) - KX(I)) < dx Then
                    S1 = S1 + Val(Mid(WS(j), InStr(WS(j), "=") + 1))
                End If
            'Exit For什么意思？
            Next j
    End If
        '画范围
       c1(0) = KX(I) - dx: c1(1) = KY(I) + dy
       c2(0) = KX(I) + dx: c2(1) = KY(I) + dy
       c3(0) = KX(I) - dx: c3(1) = KY(I) + DZ
       c4(0) = KX(I) + dx: c4(1) = KY(I) + DZ
       
       
     Set newLayer6 = ThisDrawing.Layers.Add("范围线")
      newLayer6.color = 7             ' acWhite 图层设置为红色
     ThisDrawing.ActiveLayer = newLayer6
     
      Call ThisDrawing.ModelSpace.AddLine(c1, c2)
      Call ThisDrawing.ModelSpace.AddLine(c1, c3)
       Call ThisDrawing.ModelSpace.AddLine(c4, c2)
       Call ThisDrawing.ModelSpace.AddLine(c4, c3)
      Open ThisDrawing.PaperSpace & "\汇总面积.csv" For Append As #1
         Print #1, KS(I) & "," & "S挖=" & Trim(Str(S1)) & "," & "S填=" & Trim(Str(S2))
      Close #1
Next I
 MsgBox ("提取的文件已经保存在C:\Users\Administrator\Desktop\汇总面积.csv")
sset.Delete '删除选择集
'QQ:
'If Err.Number <> 0 Then
'Dim PXX As Byte
'MsgBox (Err.Number)
'PXX = MsgBox("出现问题" + Chr(13) + Chr(10) + "1：可能是修改过图层名没有保存后重新打开文件" + Chr(13) + Chr(10) + "2：没有选中文件" + Chr(13) + Chr(10) + "3：里程桩号没在名为《桩号》的图层上" + Chr(13) + Chr(10) + "4：填挖图层名不正确" + Chr(13) + Chr(10) + "5：填挖图层名要用字母（不支持中文）", 36, "")
'End
'End If
End Sub

Private Sub TextBox2_Change()

End Sub