[VBA程序]：VBA编程中如何实现橡皮筋功能？

skylark

各位大侠：如何在VBA中实现橡皮筋功能？
如实现CAD系统的画圆弧中的橡皮筋功能。

xunix

如果通过CAD的命令调用还基本可以，如果要自己实现，难度比较大，得不偿失。

forest99bjx

如果是取点的处理，将前一个点作为参数，传递给第二个点的取得那个函数
Dim basePnt(0 To 2) As Double
basePnt(0) = 2#: basePnt(1) = 2#: basePnt(2) = 0#
returnPnt = ThisDrawing.Utility.GetPoint(basePnt, "Enter a point: ")

skylark

大侠们，有好办法吗？

雪山飞狐(lzh)

将VLAX类的EvalLispExpression子程改动一下可以实现



Public function EvalLispExpression(lispStatement As String)
    On Error GoTo ErrClear
    Dim sym As Object, ret As Object, retVal
    EvalLispExpression = ""
    Set sym = VLF.Item("read").funcall(lispStatement)
    retVal = VLF.Item("eval").funcall(sym)
    EvalLispExpression = retVal
ErrClear:
End Function



总觉得VLAX类不太健壮

测试（插入一个块，拖动并旋转）：

先导入Lisp函数dd，再生成一个名为"123"的块



Sub Test()
On Error Resume Next
    Dim obj As VLAX, retVal
    Dim a As String, b
    Dim c(2) As Double, d(2) As Double
    Dim pObj As AcadBlockReference, pLine As AcadLine
    Set obj = New VLAX
    retVal = obj.EvalLispExpression("(dd)")
    Set obj = Nothing
    a = Split(retVal, ",")(0)
    Err.Clear
    Set pObj = ThisDrawing.ModelSpace.InsertBlock(c, "123", 1, 1, 1, 0)
    ThisDrawing.Utility.Prompt vbCr & "请输入插入点:" & vbCr
    Do While a <> "3"
        Set obj = New VLAX
        retVal = obj.EvalLispExpression("(dd)")
        Set obj = Nothing
        a = Split(retVal, ",")(0)
        Err.Clear
        If a = 5 Then
            b = Split(retVal, ",")
            Err.Clear
            c(0) = b(1)
            c(1) = b(2)
            pObj.InsertionPoint = c
            Err.Clear
        End If
    Loop
    a = 5
    ThisDrawing.Utility.Prompt vbCr & "请输入旋转角度:" & vbCr
    Set pLine = ThisDrawing.ModelSpace.AddLine(c, d)
    Do While a <> "3"
        Set obj = New VLAX
        retVal = obj.EvalLispExpression("(dd)")
        Set obj = Nothing
        a = Split(retVal, ",")(0)
        Err.Clear
        If a = 5 Then
            b = Split(retVal, ",")
            Err.Clear
            c(0) = b(1)
            c(1) = b(2)
            pLine.EndPoint = c
            pObj.Rotation = ThisDrawing.Utility.AngleFromXAxis(pObj.InsertionPoint, c)
            Err.Clear
        End If
    Loop
    pLine.Delete
End Sub










Lisp函数



(defun dd()
  (setq a (grread t))
  (if (OR (= 3 (car a)) (= 5 (car a)))
    (setq str (strcat (itoa (car a))
        ","
        (rtos (caadr a) 2 4)
        ","
        (rtos (cadadr a) 2 4)
        ","
        (rtos (cadr (cdadr a)) 2 4)
       )
    )
  )
  (IF (OR (= 2 (car a)) (= 11 (car a)))
    (setq str (strcat (itoa (car a))
        ","
        (itoa (cadr a))
       )
    )
  )
    str
)

wyhph

不错，能有说明么？

雪山飞狐(lzh)

具体思路是不断调用VLAX类，用Lisp函数（DD）返回当前鼠标位置，直到按下鼠标左键为止
不过由于VLAX类不够健壮，上述测试有10％的几率会使AutoCad崩溃
最好的办法还是调用ObjectArx