Çë½Ì¸÷Î»´óÏÀ£ºÕâ¶Î³ÌÐòÎªÊ²Ä¥×Ü³öÏÖ¡°ÀàÐÍ²»Æ¥Åä¡±µÄ´íÎó£¿

liyanchao1 ·¢±íÓÚ 2004-12-28 17:06:00

Çë¸÷Î»´óÏÀ°ïÃ¦¿´Ò»ÏÂÕâ¶Î³ÌÐò£ºÎªÊ²Ä¥ÔËÐÐÊ±×ÜÊÇ³öÏÖ¡°´íÎó13£ºÀàÐÍ²»Æ¥Åä£¡¡±µÄ´íÎó£¿

'----------------------------------------------

Sub Test() On Error Resume Next Dim a As Variant Dim c(2) As Double Dim d As Double

c(0) = 100 c(1) = 100 c(2) = 0

 Do While 1 ' ½«Êó±êµÄµ±Ç°×ø±êÖµ¸³Öµ¸øa a = GetPoint d = ((c(1) - a(1)) ^ 2 + (c(0) - a(0)) ^ 2) ^ 0.5 ThisDrawing.Utility.Prompt d & vbCrLf Select Case a(2) Case -1 Exit Sub Case 0 Case 1 End Select Loop End Sub Function GetPoint() '¹¦ÄÜ£º·µ»Øµ±Ç°Êó±ê×´Ì¬ '·µ»ØÖµ£ºÒ»Î¬Êý×é '·µ»Ø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 '-----------------------------------------------------------

mccad ·¢±íÓÚ 2004-12-28 21:19:00

ÓÐÃ»ÓÐÊ¹ÓÃVLAXÀà£¿

liyanchao1 ·¢±íÓÚ 2004-12-29 09:02:00

ÎÒÒÑ¾½«Äú±àÐ´µÄVLAX.CLSµ¼Èëµ½¸Ã³ÌÐòµÄÀàÄ£¿éÖÐ.

'----------------------------------------------

' VLAX.CLS v2.0 (Last updated 8/1/2003) ' Copyright 1999-2001 by Frank Oquendo ' ' ¸Ã³ÌÐòÓÉÃ÷¾Í¨µÀÐÞ¸ÄÖ§³Ö2004°æ±¾ ' <A href="http://www.mjtd.com/" target="_blank" >http://www.mjtd.com</A> ' ' Permission to use, copy, modify, and distribute this software ' for any purpose and without fee is hereby granted, provided ' that the above copyright notice appears in all copies and ' that both that copyright notice and the limited warranty and ' restricted rights notice below appear in all supporting ' documentation. ' ' FRANK OQUENDO (THE AUTHOR) PROVIDES THIS PROGRAM "AS IS" AND WITH ' ALL FAULTS. THE AUTHOR SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY ' OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. THE AUTHOR ' DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE ' UNINTERRUPTED OR ERROR FREE. ' ' Use, duplication, or disclosure by the U.S. Government is subject to ' restrictions set forth in FAR 52.227-19 (Commercial Computer ' Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii) ' (Rights in Technical Data and Computer Software), as applicable. ' ' VLAX.cls allows developers to evaluate AutoLISP expressions from ' Visual Basic or VBA ' ' Notes: ' All code for this class module is publicly available througout various posts ' at <A href="news://discussion.autodesk.com/autodesk.autocad.customization.vba" target="_blank" >news://discussion.autodesk.com/autodesk.autocad.customization.vba</A>. I do not ' claim copyright or authorship on code presented in these posts, only on this ' compilation of that code. In addition, a great big "Thank you!" to Cyrille Fauvel ' demonstrating the use of the VisualLISP ActiveX Module. ' ' Dependencies: ' Use of this class module requires the following application: ' 1. VisualLISP

Private VL As Object Private VLF As Object

Private Sub Class_Initialize() '¸ù¾ÝAutoCADµÄ°æ±¾ÅÐ¶ÏÊ¹ÓÃµÄ¿âÀàÐÍ 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.Functions End Sub

Private Sub Class_Terminate() 'ÀàÎö¹¹Ê±£¬ÊÍ·ÅÄÚ´æ Set VLF = Nothing Set VL = Nothing End Sub

Public Function EvalLispExpression(lispStatement As String) '¸ù¾ÝLISP±í´ïÊ½µ÷ÓÃº¯Êý Dim sym As Object, ret As Object, retVal Set sym = VLF.Item("read").funcall(lispStatement) On Error Resume Next retVal = VLF.Item("eval").funcall(sym) If Err Then EvalLispExpression = "" Else EvalLispExpression = retVal End If End Function

Public Sub SetLispSymbol(symbolName As String, value)

Dim sym As Object, ret, symValue symValue = value Set sym = VLF.Item("read").funcall(symbolName) ret = VLF.Item("set").funcall(sym, symValue) EvalLispExpression "(defun translate-variant (data) (cond ((= (type data) 'list) (mapcar 'translate-variant data)) ((= (type data) 'variant) (translate-variant (vlax-variant-value data))) ((= (type data) 'safearray) (mapcar 'translate-variant (vlax-safearray->list data))) (t data)))" EvalLispExpression "(setq " & symbolName & "(translate-variant " & symbolName & "))" EvalLispExpression "(setq translate-variant nil)" End Sub

Public Function GetLispSymbol(symbolName As String)

Dim sym As Object, ret, symValue symValue = value Set sym = VLF.Item("read").funcall(symbolName) GetLispSymbol = VLF.Item("eval").funcall(sym) End Function

Public Function GetLispList(symbolName As String) As Variant Dim sym As Object, list As Object Dim Count, elements(), i As Long Set sym = VLF.Item("read").funcall(symbolName) Set list = VLF.Item("eval").funcall(sym) Count = VLF.Item("length").funcall(list) ReDim elements(0 To Count - 1) As Variant For i = 0 To Count - 1 elements(i) = VLF.Item("nth").funcall(i, list) Next GetLispList = elements End Function

Public Sub NullifySymbol(ParamArray symbolName())

Dim i As Integer For i = LBound(symbolName) To UBound(symbolName) EvalLispExpression "(setq " & CStr(symbolName(i)) & " nil)" Next End Sub

'------------------------------------------------------

Ñ©É½·Éºü_lzh ·¢±íÓÚ 2004-12-29 20:29:00

×îºÃÕû¸öDo WhileÑ»·ÓÃLispÊµÏÖ£¬ÔÙÓÃVBAÀûÓÃVLAXÀàµ÷ÓÃ£¬·ñÔò¹ý²»ÁËÒ»»á¾Í»á±ÀÀ£µô

liyanchao1 ·¢±íÓÚ 2004-12-30 09:30:00

·ÉºüÀÏÐÖ£ºÇë¸ø³öÏêÏ¸µÄ³ÌÐò´úÂë£¬ºÃÂð£¿

Ñ©É½·Éºü_lzh ·¢±íÓÚ 2004-12-30 09:36:00

<A href="http://www.vba.cn/bbs/dispbbs.asp?boardid=4&star=1&replyid=21264&id=20448&skin=0&page=1" target="_blank" >http://www.vba.cn/bbs/dispbbs.asp?boardid=4&star=1&replyid=21264&id=20448&skin=0&page=1</A>

liyanchao1 ·¢±íÓÚ 2004-12-30 11:26:00

´óÏÀ£ºÎÒÏëÖªµÀÎªÊ²Ä¥ÔÚ³ÌÐòÖ´ÐÐµ½£º

d = ((c(1) - a(1)) ^ 2 + (c(0) - a(0)) ^ 2) ^ 0.5 

Ê±×ÜÊÇ³öÏÖ¡°ÔËÐÐ´íÎó13£ºÀàÐÍ²»Æ¥Åä¡±£¿

Æµ·±µ÷ÓÃGetPointº¯Êý»áÒý·¢´íÎó£¬¶øGetPointº¯ÊýÄÚ´íÎó´¦ÀíµÄ½á¹ûÊÇaÎªNull

Ò³: [1]

Ã÷¾­CADÉçÇø's Archiver

Ã÷¾CADÉçÇø's Archiver