'重命名图块
Sub ReNameBLock()
    On Error Resume Next
    Dim E As AcadEntity
    Dim P As Variant
    Dim B As AcadBlockReference
    ThisDrawing.Utility.GetEntity E, P, "选择一个你要重命名的参照块: "
    If Err <> 0 Then Exit Sub
    Dim NewName As String
    NewName = InputBox("输入新的图块名称:", "田草结构工具箱")
    If NewName = "" Then Exit Sub
    If Err = 0 Then
        If E.ObjectName = "AcDbBlockReference" Then
            Set B = E
            ThisDrawing.Blocks(B.name).name = NewName
        End If
    End If
End Sub

'对象居中
'天正建筑中的窗居墙体中间
'   在此操作之前应该将窗编号隐藏
Sub Center_E2E_Center1()
    Dim P As Variant
    Dim E As AcadEntity
    Dim SSet As AcadSelectionSet
    Dim I As Long
    Dim PC1 As Variant, PC2 As Variant
    Dim Wall As AcadEntity
    On Error GoTo xErr
xNext:
    ThisDrawing.Utility.GetEntity E, P, "第一个窗对象:"
    PC1 = GetCenter(E)
    Set SSet = GetE_SideByE(E)
    For I = 0 To SSet.Count - 1
        'Prompt SSet.item(I).ObjectName & vbCrLf
        If SSet.item(I).ObjectName = "TDbWall" Then
            Set Wall = SSet.item(I)
            PC2 = GetCenter(Wall)
            E.Move PC1, PC2
        End If
    Next I
xErr:
End Sub

'找到一个CAD对象附近的CAD对象
Function GetE_SideByE(E As AcadEntity) As AcadSelectionSet   '返回
    Dim Pmin As Variant, Pmax As Variant
    E.GetBoundingBox Pmin, Pmax
    Dim SSet  As AcadSelectionSet
    Set SSet = CreateSelectionSet("XX")
    'SSet.Select acSelectionSetWindow, Pmin, Pmax
    SSet.Select acSelectionSetCrossing, Pmin, Pmax
    Set GetE_SideByE = SSet
End Function