[转贴]：CustomDblClkedit

hqd9639

Option Explicit

'' The program is povided AS IS with no expressed written warranty
'' Copyright 2003 - HyperPics
''
'' You can freely use this code for personal use and as long as you
'' keep the reference to the original author in place.  This code can not be used
'' in a commercial for sale product without written consent from the original
'' author.
''
'' Created by Lee Ambrosius (lee_ambrosius@hyperpics.com)
''            HyperPics.com
''
'' Created on 03/06/03
''
'' Last updated 05/07/03
'' - Corrected minor problem with behavior that was undone and removed double click problem
''   when nothing was selected in the drawing
''
'' Updated 05/06/03
'' - Corrected minor problem with single editor objects that got disabled when making change for
''   multiple objects from update done on 5/05/03
''
'' Update - 05/05/03
'' - Corrected problem with deselecting lines and other specific objects not covered in conditionals
'' - Added support for the PickFirst System Variable.  If PickFirst = 0 then nothing happens
'' - Added support for single object selection conditional so it works like the standard
''   Double Click functionality of AutoCAD.
''
'' Update - 03/10/03
'' - Corrected UCS problem with it being rotated and reporting the corrdinates in correctly
''
'' Update - 03/07/03
'' - Added support for all Dim objects
'' - Xref support was enhanced to work with Absolute, Relative and No Path options
'' - Rtext support if the Rtext.arx is loaded
'' - Added support for 2002 and 2004 to use the Enhanced Attribute box
'' - Added Z point value to point
'' - Attribute Defintion
'' - Text
'' - Ployline
'' - Spline
'' - Mline
''
'' What do you need?
'' Windows 98 or higher
'' I.E. 5 or higher
'' Microsoft Script Host 5.6 (recommended)
'' AutoCAD 2000i or higher
''
'' How to use:
'' DblkClkEdit needs to be set to Off in AutoCAD. Paste the code into the ThisDrawing
'' class module inside of the VBAIDE.

Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant)
  If CStr(ThisDrawing.GetVariable("PICKFIRST")) = "1" Then
    Dim acadObj As AcadObject
    Dim ssetObj As AcadSelectionSet
   
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Add("MySSet")
    If Err <> 0 Then
      Set ssetObj = ThisDrawing.SelectionSets.Item("MySSet")
      Err.Clear
    End If
      
    Set ssetObj = ThisDrawing.PickfirstSelectionSet
      
    If ssetObj.Count = 1 Then
      PickPoint = ThisDrawing.Utility.TranslateCoordinates(PickPoint, acWorld, acUCS, False)
            
      Dim blkObj As AcadBlockReference
      Dim exBlkObj As AcadExternalReference
      
      '' Grab each object out of the selection set
      For Each acadObj In ssetObj
        '' Push to the Immediate Window the Object Name
        Debug.Print acadObj.ObjectName
        
        If acadObj.ObjectName = "AcDbRotatedDimension" Then ' Rotated Dimension
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbAlignedDimension" Then ' Aligned Dimension
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbDiametricDimension" Then ' Diameter Dimension
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbRadialDimension" Then ' Radius Dimension
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDb2LineAngularDimension" And acadObj.ObjectName = "AcDb3LineAngularDimension" Then ' Angular Dimension
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbOrdinateDimension" Then ' Ordinate Dimension
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbFcf" Then ' Tolerance
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbMText" Then ' Multi-line Text
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._Mtedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
        ElseIf acadObj.ObjectName = "AcDbText" Then ' Text
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "RText" Then ' Remote Text - Edit
          '' Get the list of loaded ObjectARX applications
          Dim arxList As Variant, bArxFlag As Boolean
          arxList = ThisDrawing.Application.ListArx
          bArxFlag = False
         
          '' Loop through the array
          If VarType(arxList) <> vbEmpty Then
            Dim I As Integer
            For I = LBound(arxList) To UBound(arxList)
              If UCase(arxList(I)) = "RTEXT.ARX" Then
                bArxFlag = True
              End If
            Next
          End If
         
          '' If the flag is true then Remote Text Express Tool is loaded
          If bArxFlag = True Then
            ssetObj.SelectAtPoint PickPoint
            ThisDrawing.SendCommand "._Rtedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " E  "
          End If
        ElseIf acadObj.ObjectName = "AcDbAttributeDefinition" Then ' Attribute not in block
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._DDedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & "  "
        ElseIf acadObj.ObjectName = "AcDbHatch" Then ' Hatch
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._hatchedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
        ElseIf acadObj.ObjectName = "AcDbPolyline" Then ' Ployline
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._Pedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
        ElseIf acadObj.ObjectName = "AcDbSpline" Then ' Spline
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._Splinedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
        ElseIf acadObj.ObjectName = "AcDbMline" Then ' Mline
          ssetObj.SelectAtPoint PickPoint
          ThisDrawing.SendCommand "._Mledit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
        ElseIf acadObj.ObjectName = "AcDbBlockReference" Then ' Block Insert or External Reference
          Set blkObj = acadObj
         
          On Error GoTo NoXref
          Set exBlkObj = acadObj
   
Xref:
    ' Xref can have or not have attributes
          If exBlkObj.HasAttributes Then
            '' Reference to enhanced Attribute editor - R2002 and 2004
            If Left(ThisDrawing.GetVariable("ACADVER"), 5) = "15.06" Or Left(ThisDrawing.GetVariable("ACADVER"), 3) = "16.0" Then
              ssetObj.SelectAtPoint PickPoint
              ThisDrawing.SendCommand "._Eattedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
            Else '' Reference to old Attribute editor - R2000i
              ssetObj.SelectAtPoint PickPoint
              ThisDrawing.SendCommand "._Ddatte " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
            End If
          Else
            Dim Msg As String
            Dim Response As Integer
            Dim fso As Object
            Set fso = CreateObject("Scripting.FileSystemObject")
   
            Msg = "Do you want to open this Xref?" + vbCr _
              + "Block Name: " + exBlkObj.Name + vbCr
            
            If fso.fileexists(ThisDrawing.Path & "\" & exBlkObj.Path) = True Then
              Msg = Msg + "Xref Path:  " + ThisDrawing.Path + "\" & exBlkObj.Path
            ElseIf fso.fileexists(exBlkObj.Path) = True Then
              Msg = Msg + "Xref Path:  " + exBlkObj.Path
            End If
            
            Response = MsgBox(Msg, vbYesNo + vbQuestion + vbDefaultButton1, "Open Xref")
            If Response = vbYes Then   ' User choose Yes.
              If CInt(ThisDrawing.GetVariable("SDI")) = 0 Then ' Check for MDE
                If fso.fileexists(ThisDrawing.Path & "\" & exBlkObj.Path) = True Then
                  ThisDrawing.Application.Documents.Open ThisDrawing.Path & "\" & exBlkObj.Path
                ElseIf fso.fileexists(exBlkObj.Path) = True Then
                  ThisDrawing.Application.Documents.Open exBlkObj.Path
                End If
              Else
                If fso.fileexists(ThisDrawing.Path & "\" & exBlkObj.Path) = True Then
                  ThisDrawing.Open ThisDrawing.Path & "\" & exBlkObj.Path
                ElseIf fso.fileexists(exBlkObj.Path) = True Then
                  ThisDrawing.Open exBlkObj.Path
                End If
              End If
            Else    ' User choose No.
              GoTo EndBlock
            End If
          End If
         
          Set fso = Nothing
         
          GoTo EndBlock
         
NoXref:
    ' Block can have or not have attributes
          If blkObj.HasAttributes Then
            '' Reference to enhanced Attribute editor - R2002 and 2004
            If Left(ThisDrawing.GetVariable("ACADVER"), 5) = "15.06" Or Left(ThisDrawing.GetVariable("ACADVER"), 4) = "16.0" Then
              ssetObj.SelectAtPoint PickPoint
              ThisDrawing.SendCommand "._Eattedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
            Else '' Reference to old Attribute editor - R2000i
              ssetObj.SelectAtPoint PickPoint
              ThisDrawing.SendCommand "._Ddatte " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
            End If
          Else
            ssetObj.SelectAtPoint PickPoint
            ThisDrawing.SendCommand "._Refedit " & CStr(PickPoint(0)) & "," & CStr(PickPoint(1)) & "," & CStr(PickPoint(2)) & " "
          End If
   
EndBlock:
        Else ' Other objects not handled above
          ThisDrawing.SendCommand "'._properties "
        End If
      Next
    ElseIf ssetObj.Count > 1 Then
      ThisDrawing.SendCommand "'._properties "
    End If
   
    '' Delete Selection Set
    ssetObj.Delete
  End If
End Sub