社区 › VB › 取消定义/重新定义Xref

cadpro 发表于 2007-3-22 06:00:58

取消定义/重新定义Xref

嗨，
我想创建一个VBA模块来取消xref命令的定义，然后创建一个名为“Xref”的新命令，然后重新定义它。这可能吗？请帮帮忙。谢谢
**** Hidden Message *****

cadpro 发表于 2007-3-22 09:05:07

不。

Bryco 发表于 2007-3-27 01:25:58

重新定义...事实上没有必要...当用户在命令行中键入xref时，ActiveUCS应该立即转到“World”，ActiveLayer应该转到“0”。之后应该会弹出Xref对话框。通过xref对话框插入绘图后，图层和ucs应该会像之前一样回到原来的位置。这可以完成吗？
谢谢

cadpro 发表于 2007-3-27 08:15:43

是的，您可以使用活动文档的 BeginCommand 事件来执行此操作。

Bryco 发表于 2007-3-27 10:12:00

不要忘记XATTACH。

cadpro 发表于 2007-3-28 00:32:13

这是我写的代码。但不幸的是，它不起作用。
请帮忙。
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
谢谢

Keith™ 发表于 2007-3-28 08:15:58

我认为在开始另一个命令时，您无法有效地使用sendkeys函数。您可能希望以编程方式设置UCS，而不是使用sendkeys函数。

cadpro 发表于 2007-3-28 10:24:27

这似乎可行。
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

Bryco 发表于 2007-3-28 23:57:56

我复制了WCS，一切正常。但有一个问题。如果用户单击“外部参照”对话框的“取消”按钮，则不会恢复旧UCS和图层，因为它不会执行EndCommand事件。我已经给出了在EndCommand事件中恢复旧UCS和图层的代码。有解决办法吗
设置
xref命令运行
[结束命令]
此场景将重置在取消外部参照时未重置的先前设置，但是，为了捕获大多数场景，您还需要使用Begin Lisp事件验证设置。

cadpro 发表于 2007-3-29 00:26:52

Keith，
很抱歉我没有理解你解释的解决方法。我会给出我所做的代码。希望你能对代码进行更改，这让我更好地理解。
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
如果我没有错，我理解如果Xref对话框被取消，执行控件永远不会进入EndCommand事件。请帮助。
谢谢

查看完整版本: 取消定义/重新定义Xref