選擇“工具”“引用”項(xiàng)，在彈出的“引用”對話框的“可使用的引用”列表框內(nèi)，選擇“Microsoft Excel 8.0 Object Library"項(xiàng)

'計算兩點(diǎn)之間距離
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()
 '創(chuàng)建選擇集
 For JJ = 1 To 10
 If MsgBox("是否繼續(xù)選擇", 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
    '創(chuàng)建點(diǎn)組
    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

    '獲得最左側(cè)和下側(cè)的角點(diǎn)
    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
    '獲得最上側(cè)和右側(cè)的角點(diǎn)
    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
    '創(chuàng)建Excel應(yīng)用程序?qū)嵗?br />     On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
           '創(chuàng)建一個新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel應(yīng)用程序可見
           Excel.Visible = True
          '將新創(chuàng)建的工作簿保存為Excel文件
             ExcelWorkbook.SaveAs "屬性表.xls"
    End If
    '確保Sheet1工作表為當(dāng)前工作表
    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