[综合讨论] 填充t的非lisp方法

Public Sub ModifyPitSchedule2()
' puts in 1 pt x and y's plus length and width
Dim SS As AcadSelectionSet
Dim objENT As AcadEntity
Dim Count, Cntr As Integer
Dim Newpitname As String
Dim pitname As String
Dim FilterDXFCode(0) As Integer
Dim FilterDXFVal(0) As Variant
Dim PitNameSelect As AcadObject
Dim basepnt, pt1, pt2, pt3 As Variant
Dim attribs As Variant
On Error Resume Next
Newpitname = "1"   'dummy to pass then return changed
pitname = Getpitname(Newpitname)
MsgBox "pitname selected is " & pitname
basepnt = ThisDrawing.Utility.GetPoint(, " Pick PIT center ")
ptxtx1 = CStr(FormatNumber(basepnt(0), 3))
ptxty1 = CStr(FormatNumber(basepnt(1), 3))
pt1 = ThisDrawing.Utility.GetPoint(, " Pick 1st point ")
pt2 = ThisDrawing.Utility.GetPoint(, " pick 2nd point L ")
pt3 = ThisDrawing.Utility.GetPoint(, " pick 3rd point W ")
lx = Abs((pt1(0) - pt2(0)))
ly = Abs((pt1(1) - pt2(1)))
lz = Int((lx ^ 2 + ly ^ 2) ^ 0.5 * 10000) / 10
lengthpit = CStr(FormatNumber(lz, 0))
lx = Abs((pt2(0) - pt3(0)))
ly = Abs((pt2(1) - pt3(1)))
lz = Int((lx ^ 2 + ly ^ 2) ^ 0.5 * 10000) / 10
widthpit = CStr(FormatNumber(lz, 0))
'This will clear out old selectionsets, and prevent the "selection set already exists" error
If ThisDrawing.SelectionSets.Count > 1 Then
For Cntr = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(Cntr).Delete
Next Cntr
End If
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
Set SS = ThisDrawing.SelectionSets.Add("pit2sel")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal
BLOCK_NAME = "SCHEDTEXT"
For Cntr = 0 To SS.Count - 1
If SS.Item(Cntr).Name = BLOCK_NAME Then
  attribs = SS.Item(Cntr).GetAttributes
 
    If attribs(0).TextString = pitname Then
   
       attribs(1).TextString = ptxtx1
       attribs(2).TextString = ptxty1
       attribs(5).TextString = lengthpit
       attribs(6).TextString = widthpit
       
       attribs(1).Update
       attribs(2).Update
       attribs(5).Update
       attribs(6).Update
       Cntr = SS.Count
               
      End If
       
End If
Next Cntr
ThisDrawing.SelectionSets.Item("pit2sel").Delete
End Sub
Function Getpitname(Newpitname As String) As String
Dim PitNameSelect As AcadObject
Dim pitattribs As Variant
ThisDrawing.Utility.GetEntity PitNameSelect, basepnt, "pick pit name : "
If PitNameSelect.ObjectName = "AcDbText" Then
 Getpitname = PitNameSelect.TextString
End If
If PitNameSelect.ObjectName = "AcDbBlockReference" Then
 pitblname = PitNameSelect.Name   ' RETURNS BLOCK NAME
 pitattribs = PitNameSelect.GetAttributes
 Getpitname = pitattribs(0).TextString
End If
End Function