选择CAD线条 EXCEL记录长度（连续选择，完美修改）

选择“工具”“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
    Dim y As Double
    Dim z As Double
    x = ptSt(0) - ptEn(0)
    y = ptSt(1) - ptEn(1)
    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function
 
Private Sub xz()
 '创建选择集
 For JJ = 1 To 10
 If MsgBox("是否继续选择", vbYesNo) = vbNo Then
 Exit For
Else
    On Error Resume Next
    Set myyactiveDoc = ActiveDocument

    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    SSet.SelectOnScreen
    '创建点组
    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
    Dim count As Integer
    count = SSet.count
    ReDim ptArr1(count - 1)
    ReDim ptArr2(count - 1)
    '错误判断
    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
    End If

    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
    Dim i As Integer
    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
    Next
    '获得最上侧和右侧的角点
    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
    Next
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
    Dim ptRight, ptTop
   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)
 
    Dim pppt1(0 To 2) As Double
    Dim pppt2(0 To 2) As Double
        pppt1(2) = 0
        pppt2(2) = 0
    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
    For j = 1 To Int(Val(HjigeCb.Text))
      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
         pppt2(0) = pppt1(0) + gzkuan
         pppt2(1) = pppt1(1) - gzgao

      Next
    Next
         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
  Next
    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
    End If
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
    ExcelSheet.Range("A" & endrow) = KK
    Set Excel = Nothing
    End If
  Next
End Sub