Interactive Insert VBA

[meyerforhire]

I'm trying to build a "smarter" insert routine for placing furniture blocks. What I mean by "smarter" is I'd like the user to be able to control, preferably by keystroke, whether to mirror the block or rotate it by a fixed angle on each depression of whatever key I decided. The problem I'm having is I don't even know how to properly "search" for help without finding mounds of nonrelevant information.

 

The biggest issue I can't find resolution for, is being able to keep the block ghosted on my mouse throughout and having that ghosted block update with the user input until it is finaly placed. Really, the rotation could come at the end, I just want to be able to have a visible insert routine with a mirror option.

 

What's frustrating is I know it can be done--I've seen it using a furniture vendor's proprietary ACAD applet. I have been able to take the applet apart--somewhat--but I believe what I'm looking for in this applet is LISP. I don't understand LISP all that great and I'd really like to be able to use VBA. I've been able to get small, digestible snippets of LISP to work in conjunction with VBA, but that's about it.

 

The closest I've gotten so far, is to use several small sub routines--like:

 
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

 

By closest, I mean I've figured out that I can run sub routines inside of the InsertBlock routine. Really, I don't even know if I'm on the right path with this.

 

Another route I'm considering but don't even know how to invoke is to get VBA to replicate the live action equivalent of grabbing a block by its insertion point grip. You know, when your in ACAD and you highlight a block and then click it's insertion point grip, you now have ahold of that block until you click elsewhere in the drawing to place it. I think if I could figure that out in VBA or LISP, I could get the rest of the stuff to fall in line.

 

Any help would be oh so greatly appreciated.

 

Thanks!

[meyerforhire]

UPDATE:

 

The other route I mentioned--"Another route I'm considering but don't even know how to invoke is to get VBA to replicate the live action equivalent of grabbing a block by its insertion point grip. You know, when your in ACAD and you highlight a block and then click it's insertion point grip, you now have ahold of that block until you click elsewhere in the drawing to place it. I think if I could figure that out in VBA or LISP, I could get the rest of the stuff to fall in line."

 

This is just another way to invoke the STRETCH command, so I doubt it will be helpful.

[SEANT]

With regard to visual feedback, VBA is a poor programming interface. The process is not possible with just VBA, but several workarounds have been suggested. Here is one former thread where the topic was discussed:

 

 

 

http://www.cadtutor.net/forum/showthread.php?23468

 

 

 

 

 

Operations requiring visual feedback are significantly more feasible in Lisp or VB.NET.

[meyerforhire]

SEANT,

 

Thanks for the reply! Unfortunately, in the referenced post, frostrap never posted the LISP he eluded to ultimately using.

 

Whilst waiting for a reply, I headed down another road and decided to invoke the "-insert" via lisp then selected that block via acSelectionSetLast in an attempt to use keyboard input to alter the block. However, I'm not using the utility for input, I'm attempting to run several API functions to look for what key gets pressed. I'm getting some really wild, wild things out of it--like once I press the left or right arrow keys, the block spins like a propellar and, while being very intertaining, ultimately causes a crash.

 

I'll post the code and if you feel like picking it apart, please do. If not, it's okay, I'm just going to keep slogging until something works.

 

 
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

 

I know it's extremely rough, but I'm learning bunches.

 

I think, in the near future, I will start heading down the .Net road--it's where everything is basically heading anyway.

 

Thanks again!

Edited September 8, 2011 by meyerforhire
Added API Declerations