'重命名图块
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

'选择颜色对话框
Private Declare Function acedSetColorDialog Lib "acad.exe" _
     (color As Long, ByVal bAllowMetaColor As Boolean, ByVal nCurLayerColor As Long) As Boolean
'显示提示对话框
Private Declare Function acedAlert Lib "acad.exe" (ByVal str As String) As Long

' 显示文本窗口(AutoCAD 命令行文本窗口)
Private Declare Function acedTextScr Lib "acad.exe" () As Long
' 隐藏文本窗口
Private Declare Function acedGraphScr Lib "acad.exe" () As Long
' 命令行提示
Private Declare Function acedPrompt Lib "acad.exe" (ByVal str As String) As Boolean
' 卸载 arx
Private Declare Function acedArxUnload Lib "acad.exe" (ByVal str As String) As Long

Sub Center_E2E_Center()
    Dim P As Variant
    Dim P1 As Variant, P2 As Variant
    Dim E1 As AcadEntity
    Dim E2 As AcadEntity
    On Error GoTo xErr
xNext:
    ThisDrawing.Utility.GetEntity E1, P, "第一个对象:"
    P1 = GetCenter(E1)
    E1.Visible = False
    ThisDrawing.Utility.GetEntity E2, P, "第二个对象:"
    P2 = GetCenter(E2)
    E1.Move P1, P2
    E1.Visible = True
    GoTo xNext
xErr:
End Sub

影音源文件地址：http://www.ntsjyt.net/gx/1.swf