[VBA函数]：求助：面域问题

qiaqiadeng

鄙人想实现这样一个功能：在一个封闭区域内点一下，则在该封闭区域里建立一个面域，请高手支招。

雪山飞狐(lzh)

用Sendcommand函数发送命令

xiaodang123

Sub getreginpoint() '获得面域的内部点
Dim reg As AcadRegion
Dim pt As Variant
Dim objpoly As AcadLWPolyline
Dim minpoint As Variant
Dim maxpoint As Variant
n = ThisDrawing.ModelSpace.Count
Dim ss As AcadSelectionSet
    If ThisDrawing.SelectionSets.Count <> 0 Then
        For i = 0 To ThisDrawing.SelectionSets.Count - 1
           Set ss = ThisDrawing.SelectionSets.Item(i)
          ss.Delete
        Next i
      End If
   Set ss = ThisDrawing.SelectionSets.Add("ss0")
   Dim gpcode(0 To 1) As Integer
   Dim datavalue(0 To 1) As Variant
   gpcode(0) = 0
   gpcode(1) = 8
   datavalue(0) = "REGION"
   datavalue(1) = 0
   ss.Select acSelectionSetAll, , , gpcode, datavalue
   'MsgBox ss.Count
   Set reg = ss.Item(0)

  reg.GetBoundingBox minpoint, maxpoint
  'MsgBox minpoint(0)
  'pt = ThisDrawing.Utility.GetPoint(, "指定内部点：")
  Dim pt1(0 To 2) As Double
  pt1(0) = (minpoint(0) + maxpoint(0)) / 2
  pt1(1) = (minpoint(1) + maxpoint(1)) / 2
  pt1(2) = 0
  'MsgBox pt1(0)
pt = CVar(pt1)
ThisDrawing.SendCommand "-Boundary" & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr

  If ThisDrawing.ModelSpace.Count > n Then
  Set objpoly = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.Count - 1)
  objpoly.color = acByBlock
Else
  MsgBox "未发现现有效的边界"
  End If
Dim sset As AcadSelectionSet
    If ThisDrawing.SelectionSets.Count <> 0 Then
        For i = 0 To ThisDrawing.SelectionSets.Count - 1
           Set sset = ThisDrawing.SelectionSets.Item(i)
          sset.Delete
        Next i
      End If
   Set sset = ThisDrawing.SelectionSets.Add("ss0")
  selectbypoly sset, objpoly, acSelectionSetWindowPolygon
  MsgBox sset.Count
objpoly.Delete
End Sub
改一改就行了

qiaqiadeng

那人在阑珊处啊，直接用boundary就行了。

again100_lg

四楼说的对,直接调用boundary命令就可实现