取消定义/重新定义Xref

Option Explicit
Dim CurUCS As AcadUCS
Dim CurLayer As AcadLayer
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
If CommandName = "XREF" Or CommandName = "XATTACH" Then
Set CurUCS = ThisDrawing.ActiveUCS
Set CurLayer = ThisDrawing.ActiveLayer
SendKeys "{Esc}"
ThisDrawing.SendCommand "ucs" & vbCr & "world" & vbCr
ThisDrawing.Layers("0").Freeze = False
ThisDrawing.Layers("0").LayerOn = True
ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
End If
End Sub
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
If CommandName = "XREF" Or CommandName = "XATTACH" Then
ThisDrawing.ActiveUCS = CurUCS
ThisDrawing.ActiveLayer = CurLayer
End If
End Sub

Sub owcs()
    Dim zero(2) As Double
    Dim Xaxis(2) As Double
    Dim Yaxis(2) As Double
    Dim strNm As String, sUcs As String
    Dim oUcs As AcadUCS
   
    If ThisDrawing.GetVariable("WORLDUCS") = 1 Then
        Exit Sub
    Else
        sUcs = ThisDrawing.GetVariable("UCSNAME")
        'Debug.Print sUcs
        Xaxis(0) = 1: Yaxis(1) = 1
        Set oUcs = ThisDrawing.UserCoordinateSystems.Add(zero, Xaxis, Yaxis, "World")
        ThisDrawing.ActiveUCS = oUcs
    End If
End Sub

Option Explicit
Dim CurUCS As AcadUCS
Dim CurLayer As AcadLayer
Dim UCSs As Object
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
If CommandName = "XREF" Or CommandName = "XATTACH" Then
    Set CurUCS = ThisDrawing.ActiveUCS
    Set CurLayer = ThisDrawing.ActiveLayer
    Call ShowWCS
    ThisDrawing.Layers("0").Freeze = False
    ThisDrawing.Layers("0").LayerOn = True
    ThisDrawing.ActiveLayer = ThisDrawing.Layers("0")
End If
End Sub
Sub ShowWCS()
'
'   Display WCS
'
    Dim wcs As Object
    Dim dorigin(0 To 2) As Double
    Dim dxAxisPnt(0 To 2) As Double
    Dim dyAxisPnt(0 To 2) As Double
        
    dorigin(0) = 0#
    dorigin(1) = 0#
    dorigin(2) = 0#
    
    dxAxisPnt(0) = 1#
    dxAxisPnt(1) = 0#
    dxAxisPnt(2) = 0#
    
    dyAxisPnt(0) = 0#
    dyAxisPnt(1) = 1#
    dyAxisPnt(2) = 0#
    
    Set wcs = ThisDrawing.UserCoordinateSystems.Add(dorigin, dxAxisPnt, dyAxisPnt, "WORLD")
'    Display WCS.
    ThisDrawing.ActiveUCS = wcs
    
End Sub
Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
If CommandName = "XREF" Or CommandName = "XATTACH" Then
    ThisDrawing.ActiveUCS = CurUCS
    ThisDrawing.ActiveLayer = CurLayer
    ThisDrawing.UserCoordinateSystems.Item("World").Delete
End If
End Sub