in my drawing i have a different rectangles
i get some point and create a close polyline
Dim LastObj As AcadEntity
Dim objLWPolyline(0) As AcadLWPolyline
Dim minExt As Variant
Dim maxExt As Variant
Dim MTextObj As AcadMText
Dim corner(0 To 2) As Double
Dim Pt As Variant, _
varArea As String, _
pstr As String, _
SysVarName As String, _
sysVarName2 As String, _
VarData As Variant, _
intData As Double, _
textObj As AcadText, _
text As Variant, _
Height As Variant, _
Msg As String, _
varMinPt As Variant, _
varMaxPt As Variant
Private Sub test()
SysVarName = "DIMSCALE"
sysVarName2 = "AREA"
With ThisDrawing
.SetVariable "OSMODE", 0
.SetVariable "CMDECHO", 0
'' Multiple getpoint method by Tony Tanzillo
Msg = vbCrLf & "Select an Internal Point"
Do
On Error Resume Next
Pt = .Utility.GetPoint(, Msg)
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
pstr = Replace(CStr(Pt(0)), ",", ".") & "," & _
Replace(CStr(Pt(1)), ",", ".")
.SendCommand Chr(3) & Chr(3) & "._-boundary" & vbCr & pstr & vbCr & vbCr
Set LastObj = .ModelSpace.Item(.ModelSpace.Count - 1)
If TypeOf LastObj Is AcadLWPolyline Then
Set objLWPolyline(0) = LastObj
objLWPolyline(0).GetBoundingBox varMinPt, varMaxPt
objLWPolyline(0).Delete
End If
corner(0) = varMinPt(0): corner(1) = varMaxPt(1): corner(2) = 0#
Height = 2000#
Set MTextObj = .ModelSpace.AddMText(corner, 10, "50")
MTextObj.Height = Height
' MTextObj.Rotate MTextObj.insertionPoint, lineObj.Angle
' MTextObj.Move MTextObj.insertionPoint, lineObj.endPoint
' Set textObj = .ModelSpace.AddText(varArea, Pt, Height)
' textObj.Update
Msg = vbCrLf & "Next Internal Point or ENTER to exit: "
Loop
On Error GoTo 0
.SetVariable "OSMODE", 703
.SetVariable "CMDECHO", 1
End With
MsgBox "Done"
End Sub