'判断两个线段是否有重合的部分,重合则合并成一根线段
Function IsLineChongHe(L1 As AcadLine, L2 As AcadLine, ByRef L3 As AcadLine)
    Dim PList(3) As Variant
    Dim Len1 As Double, Len2 As Double, Len3 As Double, Len4 As Double, Len5 As Double

    If L1.angle - L2.angle = 0 Or Abs(L1.angle - L2.angle) = Atn(1) * 4 Then '直线方向相同或直线方向相反。
           PList(0) = L1.StartPoint: PList(1) = L1.EndPoint
           PList(2) = L2.StartPoint: PList(3) = L2.EndPoint
           Len1 = L1.length + L2.length
           Len2 = P2PDistance(PList(0), PList(2))
           Len3 = P2PDistance(PList(0), PList(3))
           Len4 = P2PDistance(PList(1), PList(2))
           Len5 = P2PDistance(PList(1), PList(3))
           
           If Len1 > Len2 And Len1 > Len3 And Len1 > Len4 And Len1 > Len5 Then '有重合部分(任意两点间长度不会大于两线段长度之和)
                DianPaiXu1 PList '点排序,找到最大的点和最小的点,绘制新线段
                Set L3 = ThisDrawing.ModelSpace.AddLine(PList(0), PList(3))
                'L3.color = acRed
                L1.Delete
                L2.Delete
           End If
    End If
End Function

'对象居中
'天正建筑中的窗居墙体中间
'   在此操作之前应该将窗编号隐藏
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