<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328</A>
<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328</A>
<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9328</A>
本帖最后由 作者 于 2004-5-12 15:39:02 编辑
将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:
Err.Clear
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
)
本帖最后由 作者 于 2004-5-12 16:35:20 编辑
还是VLAX类不够健壮的原因，上述测试有10％的几率会使AutoCad崩溃
可能需要在VBA与Lisp间传递数据，使VBA中的While语句等VLAX处理完Lisp语句后再运行下次循环
或者将程序分为两部分，橡皮筋处理用Lisp做，其余的用VBA做
本帖最后由 作者 于 2004-5-13 18:06:03 编辑
Function GetPoint()
'功能：返回当前鼠标状态
'Vlax类请小心使用，该函数可能使AutoCad崩溃
'返回值：一维数组
'返回0，0，－1表示按下鼠标左键，返回0，0，1表示按下鼠标右键，返回a，b，0表示当前鼠标坐标
On Error GoTo ErrClear
Dim obj As VLAX
Dim pRetVal(2) As Double, retVal
Set obj = New VLAX
obj.EvalLispExpression ("(setq a (grread t) b (car a) c (cadr a))")
Select Case obj.GetLispSymbol("b")
Case 3
pRetVal(2) = -1
Case 5
retVal = obj.GetLispList("c")
pRetVal(0) = retVal(0)
pRetVal(1) = retVal(1)
Case Else
pRetVal(2) = 1
End Select
GetPoint = pRetVal
ErrClear:
Set obj = Nothing
End Function Sub Test()
On Error Resume Next
Dim c(2) As Double
Do While 1
a = GetPoint
ThisDrawing.Utility.Prompt a(0) & "," & a(1) & "," & a(2) & vbCrLf
Select Case a(2)
Case -1
Exit Sub
Case 0
Case 1
End Select
Loop
End Sub
lzh741206发表于2004-5-13 13:01:00static/image/common/back.gifFunction GetPoint()'功能：返回当前鼠标状态'Vlax类请小心使用，该函数可能使A...求助VLAX的使用,上面这段程序怎么用不了,好象直接跳出去了,Private Sub Class_Initialize() If Left(ThisDrawing.Application.Version, 2) = "15" Then
Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
ElseIf Left(ThisDrawing.Application.Version, 2) = "16" Then
Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
End If
Set VLF = VL.ActiveDocument.FunctionsEnd Sub到Set VL = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")直接跳到ErrClear:(getpoint函数)
Set obj = Nothing
有关VL类不能使用问题主要是该控件没有注册，必须先注册。
如何注册?希望指点一下!
好复杂啊