社区 › VB › VBA动态拖动的实现

caiqs 发表于 2009-2-13 13:29:00

VBA动态拖动的实现

长久以来,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放到安装目录，不用加载
看我下边的例子程序及演
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




**** Hidden Message *****

CadDog 发表于 2009-2-13 18:52:00

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

nhy12345678 发表于 2009-2-13 21:03:00

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

wuyunpeng888 发表于 2009-2-22 19:06:00

文件未找到，无论文件放在哪里，都是一样，文件名加上路径也说文件未找到
运行时错误53

caiqs 发表于 2009-2-24 10:04:00

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

MJTD_7777 发表于 2009-3-1 23:53:00

我的也提示“文件未找到“
无论文件放在哪里，都是一样，文件名加上路径也说文件未找到
运行时错误53”
我的是 2008

lennie 发表于 2009-3-2 13:53:00

移动结束只能用右键结束么？实用性不强啊。
mylne.EndPoint = newpt后面加一句mylne.Highlight True就更像了

wuyunpeng888 发表于 2009-3-5 22:41:00

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

1051480694 发表于 2009-3-21 04:37:00

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

1051480694 发表于 2009-3-22 20:37:00

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

查看完整版本: VBA动态拖动的实现