社区 › VB › 交互式插入VBA

meyerforhire 发表于 2022-7-6 22:41:31

交互式插入VBA

我正在尝试建立一个“更智能”的插入例程来放置家具块。我所说的“更智能”是指，我希望用户能够控制，最好是通过击键，无论是镜像块还是在每次按下我决定的键时以固定角度旋转它。我遇到的问题是，我甚至不知道如何正确地“搜索”帮助，而不找到大量不相关的信息。
 
我找不到解决方案的最大问题是，能够始终在我的鼠标上保留重影块，并使用用户输入更新重影块，直到最终放置为止。实际上，旋转可能会在最后进行，我只希望能够有一个带有镜像选项的可见插入例程。
 
令人沮丧的是，我知道这是可以做到的——我见过它使用家具供应商专有的ACAD小程序。我已经能够把小程序拆开——有点——但我相信我在这个小程序中寻找的是LISP。我不太懂LISP，我真的希望能够使用VBA。我已经能够将LISP的小而易于理解的片段与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

 
我的意思是，我已经发现我可以在InsertBlock例程中运行子例程。真的，我甚至不知道我是否走对了这条路。
 
我正在考虑但甚至不知道如何调用的另一种方法是让VBA复制实景效果，相当于通过插入点抓取一个块。你知道，当你在ACAD中高亮显示一个块，然后单击它的插入点夹点时，你现在已经控制了该块，直到你在图形中的其他地方单击以放置它。我想，如果我能在VBA或LISP中解决这个问题，我就可以把其余的东西排成一行。
 
任何帮助都将不胜感激。
 
谢谢

meyerforhire 发表于 2022-7-6 23:21:08

更新：
 
我提到的另一条路线--“我正在考虑但甚至不知道如何调用的另一种方法是让VBA复制实景效果，相当于通过插入点夹点抓取一个块。你知道，当你在ACAD中高亮显示一个块，然后单击它的插入点夹点时，你现在已经控制了该块，直到你在图形中的其他地方单击以放置它。我想我是否可以在VBA或LIS中解决这个问题P、 我可以把剩下的东西排成一行。"
 
这只是调用STRETCH命令的另一种方式，因此我怀疑它是否有用。

SEANT 发表于 2022-7-6 23:40:34

关于视觉反馈，VBA是一个糟糕的编程界面。仅使用VBA无法实现该过程，但已提出了几种解决方法。这里是讨论主题的前一条线索：
 
 
 
http://www.cadtutor.net/forum/showthread.php?23468
 
 
 
 
 
在Lisp或VB中，需要视觉反馈的操作更为可行。净额。

meyerforhire 发表于 2022-7-6 23:49:34

肖恩，
 
谢谢你的回复！不幸的是，在引用的帖子中，frostrap从未发布他最终使用的LISP。
 
在等待回复的同时，我走上了另一条路，决定通过lisp调用“-insert”，然后通过acSelectionSetLast选择该块，试图使用键盘输入来更改该块。然而，我并没有使用该实用程序进行输入，而是尝试运行几个API函数来查找按下的键。我从中得到了一些非常疯狂的东西——比如，一旦我按下左箭头键或右箭头键，木块就会像螺旋桨一样旋转，虽然非常有趣，但最终会导致崩溃。
 
我会把代码贴出来，如果你想把它拆开，请把它拆开。如果没有，没关系，我只会继续努力，直到有事情发生。
 

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

 
我知道这非常粗糙，但我正在学习束。
 
我想，在不久的将来，我将开始沿着这个方向前进。网络之路——这是一切基本上都在前进的地方。
 
再次感谢！

查看完整版本: 交互式插入VBA