[编程交流] 如何在中运行vba lisp例程

Option Explicit
Function GetActiveSpace() As AcadBlock
   With ThisDrawing
       If .ActiveSpace = acModelSpace Then
           Set GetActiveSpace = .ModelSpace
       Else
           Set GetActiveSpace = .PaperSpace
       End If
       End With
   End Function
Function StoreLayerStatus() As Variant
   Dim oLayer As AcadLayer
   Dim oLayers As AcadLayers
   Dim i As Integer
   With ThisDrawing
       Set oLayers = .Layers
   End With
   ReDim layerArr(0 To oLayers.Count - 1, 0 To 2) As Variant
   For Each oLayer In oLayers
       layerArr(i, 0) = oLayer.Name
       layerArr(i, 1) = oLayer.Lock
       layerArr(i, 2) = oLayer.Freeze
       On Error Resume Next
       oLayer.Freeze = False
       If Err Then Err.Clear
       i = i + 1
   Next oLayer
   On Error GoTo 0
   StoreLayerStatus = layerArr
End Function
Private Sub RestoreLayerStatus(ByVal ar As Variant)
   Dim oLayer As AcadLayer
   Dim oLayers As AcadLayers
   Dim i As Integer
       With ThisDrawing
       Set oLayers = .Layers
   End With
   For i = LBound(ar, 1) To UBound(ar, 1)
   Set oLayer = oLayers(ar(i, 0))
   On Error Resume Next '<-- to bypass active layer
   With oLayer
   .Lock = ar(i, 1)
   .Freeze = ar(i, 2)
   End With
   If Err Then Err.Clear
   Next i
   On Error GoTo 0
   
End Sub
Sub BlockReplace()
Dim lsArr As Variant
lsArr = StoreLayerStatus
Dim oSpace As AcadBlock
Dim varPt As Variant
Dim oEnt As AcadEntity
Dim oldBlkRef As AcadBlockReference
Dim newBlkRef As AcadBlockReference
Dim oldblkName As String
Dim newblkName As String
Dim layName As String
Dim xscl As Double
Dim yscl As Double
Dim zscl As Double
Dim rot As Double
Dim insPt(2) As Double
Dim ftype(0) As Integer
Dim fdata(0) As Variant
Dim dxfCode, dxfValue
Dim oSset As AcadSelectionSet
ThisDrawing.Utility.GetEntity oEnt, varPt, vbCrLf & "Select new block instance to replace with:"
If Not TypeOf oEnt Is AcadBlockReference Then
MsgBox "Selected object isn't a block reference"
Exit Sub
End If
Set newBlkRef = oEnt
If newBlkRef.IsDynamicBlock Then
newblkName = newBlkRef.EffectiveName
Else
newblkName = newBlkRef.Name
End If
         With ThisDrawing.SelectionSets
              While .Count > 0
                   .Item(0).Delete
              Wend
         Set oSset = .Add("$ReplaceBlocks$")
         End With
         
ftype(0) = 0
fdata(0) = "INSERT"
dxfCode = ftype: dxfValue = fdata
oSset.SelectOnScreen dxfCode, dxfValue
Set oSpace = GetActiveSpace
For Each oEnt In oSset
Set oldBlkRef = oEnt
With oldBlkRef
layName = .Layer
xscl = .XScaleFactor
yscl = .YScaleFactor
zscl = .ZScaleFactor
rot = .Rotation
varPt = .InsertionPoint
insPt(0) = varPt(0): insPt(1) = varPt(1): insPt(2) = varPt(2)
.Delete
End With
Set newBlkRef = oSpace.InsertBlock(insPt, newblkName, xscl, yscl, zscl, rot)
newBlkRef.Layer = layName
Next oEnt
RestoreLayerStatus (lsArr)
ThisDrawing.Regen acActiveViewport
End Sub