VBA动态拖动的实现

caiqs

长久以来,VBA被认为在动态拖动方面是最性无能的,我通过VBA调用一个动态链接库实现了久此以来都没有解决的VBA动态拖动问题

在这里我编写了一个标准动态链接库函数，用以让VBA实时得到坐标点

在VB或VBA中，它这样被使用

Declare Function getpt Lib "CaiqsVBApinvoke.arx" (ByRef x As Double, ByRef y As Double, ByRef z As Double) As Integer

上面是函数声明

调用时

dim ret as Integer

ret = getpt(x, y, z)'这里得到实时坐标

先将附件里的arx放到AutoCAD安装目录，不用加载

看我下边的例子程序及演

Declare Function getpt Lib "CaiqsVBApinvoke.arx" (ByRef x As Double, ByRef y As Double, ByRef z As Double) As Integer
Sub aa()
Dim moda As Integer
mymode = 0
Dim x, y, z As Double
Dim ret As Integer
ret = getpt(x, y, z)
Dim abc As AcadEntity
Dim pt As Variant
ThisDrawing.ActiveSelectionSet.SelectOnScreen
Dim oldpt As Variant
Dim newpt(2) As Double
oldpt = ThisDrawing.Utility.GetPoint(, "\n指定移动起点: ")
Dim mylne As AcadLine
ret = getpt(x, y, z)
Dim startpt(2) As Double
Dim endpt(2) As Double
endpt(0) = x: endpt(1) = y: endpt(2) = z
Set mylne = ThisDrawing.ModelSpace.AddLine(oldpt, endpt)

Dim tmp(0) As Double
Do While ret = 1
ret = getpt(x, y, z)

newpt(0) = x: newpt(1) = y: newpt(2) = z
mylne.EndPoint = newpt
For Each ent In ThisDrawing.ActiveSelectionSet
ent.Move oldpt, newpt

Next

oldpt(0) = newpt(0): oldpt(1) = newpt(1): oldpt(2) = newpt(2)
Loop
mylne.Delete
End Sub

 

caddog

请问ARX可以加载到2004中吗？

nhy12345678

非常有用，但是用起来不是很方便呢，这个例子都只能通过右键结束命令，用法还需要研究下！非常感谢楼主提供的好东西！

wuyunpeng888

文件未找到，无论文件放在哪里，都是一样，文件名加上路径也说文件未找到

运行时错误53

caiqs

适用于cad04-06,arx可加载或放cad目录或放操作系统目录中

MJTD_7777

我的也提示“文件未找到“

无论文件放在哪里，都是一样，文件名加上路径也说文件未找到

运行时错误53”

我的是 2008

lennie

移动结束只能用右键结束么？实用性不强啊。

mylne.EndPoint = newpt后面加一句mylne.Highlight True就更像了

wuyunpeng888

这个功能用VL类也可以实现

1051480694

请问能用左键结束移动命令吗?这样更方便!

1051480694

我已解决用右键结束命令这个缺陷，用API函数。