|
|
长久以来,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
2v5uabadjqn.gif
本帖以下内容被隐藏保护；需要你回复后，才能看到！ 游客，如果您要查看本帖隐藏内容请 回复 |
|
置顶卡
