交互式插入VBA

 
Sub BasicInsert()
ThisDrawing.ModelSpace.InsertBlock InsPnt(), "TypicalD1", 1, 1, 1, Rot()
End Sub
Function InsPnt() As Variant
Dim Pnt1 As Variant
Pnt1 = ThisDrawing.Utility.GetPoint(, "Choose insertion point")
InsPnt = Pnt1
End Function
Function Rot()
Dim rotAng As Double
Dim InsPnt As Variant
rotAng = ThisDrawing.Utility.GetAngle(, vbCr & "Select Angle:")
End Function

 
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
Private Type KeyboardBytes
   kbByte(0 To 255) As Byte
End Type
Global Cnt As Long
Sub RunRoutine()
Dim objBlock As AcadBlock, objRef As AcadBlockReference, objMir As AcadBlockReference
Dim objEnt As AcadEntity, entArray(0) As AcadEntity
Dim FurnPath As String, blkName As String
Dim SS1 As AcadSelectionSet
Dim insPnt1 As Variant, BXmin As Variant, BXmax As Variant
Dim insPntX(0 To 2) As Double
Dim insPntY(0 To 2) As Double
Dim BXul(0 To 2) As Double
Dim rotAng As Double
Dim retKey As Boolean
Dim prsKey
Dim kbArray As KeyboardBytes
On Error Resume Next
ThisDrawing.SelectionSets.Item("insBlock").Delete
On Error GoTo 0
blkName = GetLispSym("B")
FurnPath = "C:\Program Files\Autodesk\AutoCAD 2011\Support\COE_RST-FurnApps\COE_RST-FurnBlocks.dwg"
If TestBlock(blkName) = True Then
   ThisDrawing.SendCommand blkName & vbCr
ElseIf Dir(FurnPath) = "" Then
   Do Until Dir(FurnPath) <> "" And Right(FurnPath, 4) = ".dwg"
   On vbCancel GoTo 1
       FurnPath = InputBox("Enter Block file path, i.e. C:\My Documents\ACAD Blocks\BlockFile.dwg", "Block File Path?")
           If Dir(FurnPath) = "" Then
           MsgBox "File Doesn't Exist, Try Again."
           Else
           End If
   Loop
   GetFurnBlock blkName, FurnPath
   ThisDrawing.SendCommand blkName & vbCr
Else
GetFurnBlock blkName, FurnPath
ThisDrawing.SendCommand blkName & vbCr
End If
Set SS1 = ThisDrawing.SelectionSets.Add("insBlock")
SS1.Select acSelectionSetLast
SS1.Highlight True
   For Each objEnt In SS1
   If TypeOf objEnt Is AcadBlockReference Then
   Set objRef = objEnt
   Set objEnt = Nothing
   insPnt1 = objRef.InsertionPoint
   insPntX(0) = insPnt1(0) + 1#: insPntX(1) = insPnt1(1): insPntX(2) = 0
   insPntY(0) = insPnt1(0): insPntY(1) = insPnt1(1) + 1#: insPntY(2) = 0
       Do Until retKey = True
       ThisDrawing.Utility.Prompt "UP=FlipUp/DOWN=FlipDown/RIGHT=+90/LEFT=-90" & vbCr
           For Cnt = 13 And 32 To 128
               If GetAsyncKeyState(Cnt) <> 0 Then
               prsKey = Cnt
               Exit For
               Else
               End If
           Next Cnt
       Select Case prsKey
       Case 38
           objRef.GetBoundingBox BXmin, BXmax
           BXul(0) = BXmin(0): BXul(1) = BXmax(1): BXul(2) = 0
           Set objMir = objRef.Mirror(BXul, BXmax)
           objRef.Delete
           Set objRef = Nothing
           SS1.Clear
           Set objRef = objMir
           Set objMir = Nothing
           Set entArray(0) = objRef
           SS1.AddItems entArray
           SS1.Update
           Set entArray = Nothing
       Case 40
           Set objMir = objRef.Mirror(insPnt1, insPntX)
           objRef.Delete
           Set objRef = Nothing
           SS1.Clear
           Set objRef = objMir
           Set objMir = Nothing
           Set entArray(0) = objRef
           SS1.AddItems entArray
           SS1.Update
           Set entArray = Nothing
       Case 39
           rotAng = objRef.Rotation
           objRef.Rotate insPnt1, (rotAng + 90)
       Case 37
           rotAng = objRef.Rotation
           objRef.Rotate insPnt1, (rotAng - 90)
       Case 13
       retKey = True
       End Select
       GetKeyboardState kbArray
           For Cnt = 32 To 128
           kbArray.kbByte(Cnt) = 0
           Next Cnt
       SetKeyboardState kbArray
       Loop
   Set objRef = Nothing
   Else
   End If
   Next
SS1.Clear
SS1.Delete
Set SS1 = Nothing
1
End Sub