摘要:   ;;; ************************************************************************ ;;; ***;;; ;;; vlex-vlisp.lsp             &nbs...  阅读全文

;;mode1
;;point in rection
;;点 P 是否在多边形 PM 内
;;If 'p' is in 'pm', return T.
;;'mx' is a very long distance.
(defun isInorOut (p pm / i p1 p2 tf tf1 tf2 px jp ret)
  (setq px (list (+ 1e+100 (car p)) (cadr p))
 p1 (last pm)
 i -1
  )

  (while (and (not ret)
       (setq p2 (nth (setq i (1+ i)) pm))
  )
    (if (setq jp (inters px p p1 p2))
      (if (equal (car jp) (car p) 0.0001)
 (setq ret t)
        (setq tf2 (if (> (cadr p1) (cadr p2)) 1 0)
       tf (if (= tf1 tf2) tf (not tf))
       tf1 tf2
        )
      )
      (setq tf1 nil)
    )
    (setq p1 p2)
  )

  (cond
    (ret 0)               ;线上
    (tf 1)                ;内
    (t -1)                ;外
  )
)

;;mode2方法2
;;点是否在多边形内 
(defun ptinpm (pt lst / i p1 p2 an anl ret)
  (setq i -1 p1 (last lst))
  (while (and (not ret)
       (setq p2 (nth (setq i (1+ i)) lst))
  )
    (cond
      ((equal p2 pt 1e-4) (setq ret t))
      (t
        (setq an (- (angle pt p1) (angle pt p2)))
        (if (equal pi (abs an) 1e-4)
   (setq ret t)
   (setq anl (cons (rem an PI) anl))
 )
      )
    )
    (setq p1 p2)
  )
  (cond
    (ret 0)               ;线上;
    (t
      (if (equal PI (abs (apply '+ anl)) 1e-4)
        1                 ;内;
        -1                ;外;
      )
    )
  )
)
 

 

 

 

 ;;test program

(DEFUN C:tt (/ Curve Pt lst a b c)
  (IF (SETQ Curve (CAR (ENTSEL "\n选择一条曲线:")))(progn
      (setq lst (MAPCAR (FUNCTION CDR)
                    (VL-REMOVE-IF (FUNCTION (LAMBDA (x) (/= 10 (CAR x)))) (entget Curve))
                )
      )
    (WHILE (SETQ Pt (GETPOINT "\n点取测试点:"))
      (setq pt (list (car pt) (cadr pt))
     c 1
      )

      (setq a (ptinpm Pt lst))
      (princ "\nxd-point_inm:")   (princ (cond ((= 0 a) "线上")
           ((= 1 a) "内")
           (t "外")))
     
      (setq a (xd-point_inm Pt lst))
      (princ "\nptinpm:") (princ (cond ((= 0 a) "线上")
           ((= 1 a) "内")
           (t "外")))
     
    )
  ))
  (PRINC)
)

(defun CheckSamePoint (p / p0 i exit0)
  (setq i -1)
  (while (and intps
       (setq p0 (nth (setq i (1+ i)) intps))
       (not (setq exit0 (equal p p0 1e-4)))
  )
  )
  (princ exit0)
  exit0
)

;;求直线选择集交点, 滤重复点
(defun lnsinters (ss /  n m e1 e2 el el1 p1 p2 p3 p4 intp intps)
(if (and ss (> (sslength ss) 0))(progn
  (setq n -1)
  (while (setq e1 (ssname ss (setq n (1+ n))))
    (setq el (entget e1)
   m  n
   p1 (cdr (assoc 10 el))
   p2 (cdr (assoc 11 el))
    )
    (while (setq e2 (ssname ss (setq m (1+ m))))
      (setq el1  (entget e2)
     p3  (cdr (assoc 10 el1))
     p4  (cdr (assoc 11 el1))
     intp (inters p1 p2 p3 p4)
      )
      (if (and intp (not (CheckSamePoint intp)))
 (setq intps (cons intp intps))
      )
    )
  )
))
  intps
)

(defun c:tt ()
  (princ (lnsinters (ssget)))
  (princ)
)


Line选择集交点函数.LSP

[序]

   长久以来，文本的编辑一直是lisp编程的重点、难点之一，有不少活跃在xdcad和明经通道论坛的高手为此写了不少有代表性的文字处理工具，比较知名的如：   。而我自己也写过不少这方面的程序，多数没有发表，少数零星地发布在以上两个论坛。但由于lisp对文本编辑(*注)的支持函数不够丰富，而实际工作中遇到的情况又多种多样，使得诸多lisp程序对文本编辑的深度和灵活性上还有很多不足之处，不免遗憾。

为此，我一直以来寻求更好的方法，最终只有一个答案：正则表达式。正则表达式对文本编辑很强，有多强？看看vb或vbs参考就知道，也可上网一搜。但是，也许本人孤陋寡闻(或是有的高手潜水潜得很深)，在网上一直没有见过在lisp中比较充分地应用正则表达式的程序。其实，我很早就想将正则表达式移植到lisp里面来，近几日一鼓作气，终有小成。谨奉献两个函数：(xxexp)(xxexpr)，这两个函数提供了正则表达式的接口，使在lisp中得以应用其强大的功能成为可能。                                 

 ―――――梁雄啸.2007.7

[*注:“文本”在本文均指对文本字符串内容，非指文本实体(0 . “*TEXT”)] 在lisp中应用正则表达式帮助

     摘要: 界面 dlgHDM : dialog {label = "选择输出横断面";   : row {     : column {       : row {         : text_part {label = "可选桩号";}...  阅读全文

(defun FIND_SERIALNUMBER (DRIVE / FILSYS VAL)
(setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
;;(vlax-dump-object FILSYS t)
(setq VAL (vlax-invoke FILSYS "GetDrive" DRIVE))
;;(vlax-dump-object VAL t)
(setq VAL (vl-catch-all-apply
  'vlax-get
  (list VAL "SerialNumber")
  )
)
(vlax-release-object FILSYS)
(if (vl-catch-all-error-p VAL)
(setq VAL NIL)
VAL
)
)

;获取网卡号
;;Test OK with XP
;;Use WMI to Get Networkadapter MAC.
;;Author : eachy [eachy@xdcad.net]
;;Web : http://www.xdcad.net
;;2005.11.22
(defun xdl-MACAddress (/ mac WMIobj serv lox sn)
  (vl-load-com)
  (setq mac '())
  (if (SETQ WMIobj (VLAX-CREATE-OBJECT "wbemScripting.SwbemLocator"))
    (progn (SETQ serv (VLAX-INVOKE WMIobj 'ConnectServer "." "\\root\\cimv2" "" "" "" "" 128 nil))
           (setq lox (vlax-invoke serv 'ExecQuery "Select * From Win32_NetworkAdapter "))
           (vlax-for item lox
             (if (and (= (vlax-get item 'NetConnectionID) "本地连接") ;中文系统
                      (not (member (setq sn (vlax-get item 'MACAddress)) mac))
                 )
               (setq mac (cons sn mac))
             )
           )
           (mapcar 'vlax-release-object (list lox serv WMIobj))
    )
  )
  (reverse mac)
)

 

     摘要: ;; ;; (defun rk_cp ( / p1 p2 flag lst lst2 n str                   tmp_seg p_isect) (defun tmp_seg ( p1 p2 p3 /...  阅读全文      摘要: ;******************************************************************; ; TRIANGULATE - Lisp command to create a TIN from 3D points.       ; ; ===========   ...  阅读全文      摘要: ;;;用法：先在程序命令行中输入此句：; ;;;(setenv "AutoAreaReader" "1") ;;;再加载本程序，注意，需要这样的步骤才能起作用; ;;;然后，每次点击（单击）封闭多义线，就会在命令行中得到选取多义线的面积，; ;;;一次选择多个封闭多义线的话，会得到面积总和。; ;;;如果发现给出的面积是英制的话，输入如下语句：(setq def_show_area "D...  阅读全文

(defun C:MBA ()
  (entmake
    '((0 . "block") (2 . "*U") (70 . 3) (10 0.0 0.0 0.0))
  )
  (entmake '((0 . "CIRCLE")
      (100 . "AcDbEntity")
      (67 . 0)
      (8 . "0")
      (100 . "Circle")
      (10 0.7 1.2 0.0)
      (40 . 21)
      (210 0.0 0.0 1.0)
     )
  )
  (entmake '((0 . "ATTDEF")
      (100 . "AcDbEntity")
      (67 . 0)
      (8 . "0")
      (100 . "AcDbText")
      (10 -2.4 -1.0 0.0)
      (40 . 2.5)
      (1 . "0")
      (50 . 0.0)
      (41 . 1.0)
      (51 . 0.0)
      (7 . "STANDARD")
      (71 . 0)
      (72 . 5)
      (11 0.0 0.0 0.0)
      (210 0.0 0.0 1.0)
      (100 . "AcDbAttributeDefinition")
      (3 . "请输入属性")
      (2 . "属性")
      (70 . 0)
      (73 . 0)
      (74 . 0)
     )
  )
  (setq BLKN (entmake '((0 . "ENDBLK"))))

 
  (setq LST0 '((0 . "INSERT")
        (100 . "AcDbEntity")
        (67 . 0)
        (8 . "0")
        (100 . "AcDbBlockReference")
        (66 . 1)
        (10 0.0 0.0 0.0)
        (41 . 1.0)
        (42 . 1.0)
        (43 . 1.0)
        (50 . 0.0)
        (70 . 0)
        (71 . 0)
        (44 . 0.0)
        (45 . 0.0)
        (210 0.0 0.0 1.0)
       )
  )
  (setq LST1 (append LST0 (list (cons 2 BLKN))))
  (entmake LST1)
  (entmake '((0 . "ATTRIB")
      (5 . "26")
      (100 . "AcDbEntity")
      (67 . 0)
      (8 . "0")
      (100 . "AcDbText")
      (10 -2.4 -1.0 0.0)
      (40 . 2.5)
      (1 . "123")
      (50 . 0.394791)
      (41 . 0.445714)
      (51 . 0.0)
      (7 . "STANDARD")
      (71 . 0)
      (72 . 5)
      (11 0.0 0.0 0.0)
      (210 0.0 0.0 1.0)
      (100 . "AcDbAttribute")
      (2 . "属性")
      (70 . 0)
      (73 . 0)
      (74 . 0)
     )
  )
  (entmake '((0 . "SEQEND")))
)

;转换为10进制 数值val 原始进制base
(defun baseToDecimal (base val / pos power1 result tmp)
  (setq pos (1+ (strlen val))
    power1 -1
    result 0
    val (strcase val)
  )
  (while (> (setq pos (1- pos)) 0)
    (setq result
       (+
         result
         (* (if (> (setq tmp (ascii (substr val pos 1))) 64)
          (- tmp 55)
          (- tmp 48)
        )
        (expt base (setq power1 (1+ power1)))
         )
       )
    )
  )
  result
)

;10进制转换为其他进制 数值val 目标进制base;
(defun decimalToBase (base val / result tmp)
  (setq result "")
  (while (> val 0)
    (setq result (strcat (if (> (setq tmp (rem val base)) 9)
               (chr (+ tmp 55))
               (itoa tmp)
             )
             result
         )
      val (fix (/ val base))
    )
  )
  result
)

;进制转换 数值val 原始进制base1 目标进制base2;
(defun base1tobase2 (val base1 base2 / result)
  (cond
    ((and (= (type val) 'INT) (= base1 10))
     (setq result (decimalToBase base2 val))
    )
    ((and (= (type val) 'STR) (= base1 10))
     (setq result (decimalToBase base2 (read val)))
    )
    ((= (type val) 'STR)
     (setq result (decimalToBase base2 (baseToDecimal base1 val)))
    )
    (t nil)
  )
  (if (= base2 10) (read result) result)
)

     摘要: ;|  类型库智能化加载 用法: (vlax-load-type-libeary ProgID[STRING] UniquePrefix[STR])         (vlax-load-type-libeary ProgID[STRING] PrefixList[STR])   参数1: 与vlax-...  阅读全文      摘要: ;;;在Visual LISP中使用Microsoft ActiveX Data Objects (ADO)接口与MS-Access和 ;;;SQL Server相连接的例子。 ;;; ;;;通过类型库初始化ADO接口方法： (defun DbInitADO ( / ADO_DLLPath) (if (null adom-Append) (progn ;; 尽管你可以把绝对...  阅读全文

;;Test OK with XP
;;Use WMI to Get OS name
;;Author :  eachy [eachy@xdcad.net]
;;Web    :  http://www.xdcad.net
;;2005.11.22
(defun xdl-GetOSName (/ IDs WMIobj serv lox sn)
  (vl-load-com)
  (setq IDs '())
  (if (SETQ WMIobj (VLAX-CREATE-OBJECT "wbemScripting.SwbemLocator"))
    (progn
      (SETQ serv (VLAX-INVOKE
     WMIobj     'ConnectServer     "."
     "\\root\\cimv2"  ""     ""
     ""       ""  128     nil
    )
      )
      (setq lox (vlax-invoke
    serv
    'ExecQuery
    "Select * from Win32_OperatingSystem"
  )
      )
      (vlax-for item lox
 (if (not
       (member (setq sn (vlax-get item 'Caption)) IDs)
     )
   (setq IDs (cons sn IDs))
 )
      )
      (setq a (mapcar 'vlax-release-object (list lox serv WMIobj)))
    )
  )
  (reverse IDs)
)

;;from wkai@xdcad.net
;;20050929
;;功能   :获取WINDOWS系统关键文件夹路径
;;参数folder:系统文件夹名称
;;返回值 :该文件夹所在的路径
;;示例:(XDL-WINPATH-OF "Desktop")
;;         --->>"D:\\Personal\\Desktop"
;;     (XDL-WINPATH-OF "SendTo")
;;         --->>"C:\\Documents and Settings\\Administrator\\SendTo"
;;;测试
;;;
;;;(setq winpathlst
;;;       '("AppData"  "Cookies"  "Desktop"  "Favorites"  "NetHood"
;;;  "Personal"  "My Pictures"  "PrintHood"  "Recent"  "SendTo"
;;;  "Start Menu"  "Templates"  "Programs"  "Startup"  "Local Settings"
;;;  "Local AppData" "Cache"  "History"  "Fonts"))
;;;(mapcar 'print(mapcar 'XDL-WINPATH-OF winpathlst ))
;;;(princ)
(defun XDL-WINPATH-OF(folder)
  (vl-registry-read "HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders" folder)  
)

 lsp解密程序

引：

;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2006 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;;  PlotDevicesFunctions.lsp
;;;
;;; 2003-01-09 More functions added
;;; 2006-07-30 Make it possible to add this lisp into your acaddoc.lsp
;;; 2006-12-15 Corrected a minor bug
;;;
(vl-load-com)
(defun ActLay ()
(vla-get-ActiveLayout
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
; Return the Plotter configuration name
(defun GetActivePlotDevice ()
(vla-get-ConfigName
(ActLay)
)
)
; Return the Plot style table name
(defun GetActiveStyleSheet ()
(vla-get-StyleSheet
(ActLay)
)
)
; Force the Plotter configuration to something
(defun PutActivePlotDevice (PlotDeviceName)
(vla-put-ConfigName
(ActLay)
PlotDeviceName
)
)
; Force the Plot style table to something
(defun PutActiveStyleSheet (StyleSheetName)
(vla-put-StyleSheet
(ActLay)
StyleSheetName
)
)
; Return a list of all Plotter configurations
(defun PlotDeviceNamesList ()
(vla-RefreshPlotDeviceInfo (ActLay))
(vlax-safearray->list
(vlax-variant-value
(vla-GetPlotDeviceNames
(ActLay)
)
)
)
)
; Return a list of all Plot style tables
(defun PlotStyleTableNamesList ()
(vla-RefreshPlotDeviceInfo (ActLay))
(vlax-safearray->list
(vlax-variant-value
(vla-GetPlotStyleTableNames
(ActLay)
)
)
)
)
; If the saved Plotter configuration doesn't exist set it to None
(defun PutActivePlotDeviceToNoneIfNotExist ()
(if (not (member (GetActivePlotDevice) (PlotDeviceNamesList)))
(PutActivePlotDevice "None")
)
)
; If the saved Plot style table doesn't exist set it to None
(defun PutActiveStyleSheetToNoneIfNotExist ()
(if (not
(member (GetActiveStyleSheet) (PlotStyleTableNamesList))
)
(PutActiveStyleSheet "")
)
)
; Change the Plotter configuration "CompanyStandard.pc3" to your need
(defun PutActivePlotDeviceToCompanyStandardIfNotExist ()
(if (not (member (GetActivePlotDevice) (PlotDeviceNamesList)))
(PutActivePlotDevice "CompanyStandard.pc3")
)
)
; Change the Plot style table "CompanyStandard-A3-BW.ctb" to your need
(defun PutActiveStyleSheetToCompanyStandardIfNotExist ()
(if (not
(member (GetActiveStyleSheet) (PlotStyleTableNamesList))
)
(PutActiveStyleSheet "CompanyStandard-A3-BW.ctb")
)
)
; Change the Plotter configuration to the default one set in the options
; if the active plot device does not exist
(defun PutActivePlotDeviceToDefaultIfNotExistOrNone ()
(if (or (not (member (GetActivePlotDevice) (PlotDeviceNamesList)))
(= (GetActivePlotDevice) "None")
)
(if (= (vla-get-UseLastPlotSettings
(vla-get-output
(vla-get-preferences (vlax-get-acad-object))
)
)
:vlax-true
)
(PutActivePlotDevice
(getenv "General\\MRUConfig")
)
(PutActivePlotDevice
(vla-get-DefaultOutputDevice
(vla-get-output
(vla-get-preferences (vlax-get-acad-object))
)
)
)
)
)
)
; Change the Plot style table to the default one set in the options
; if the active Plot style table does not exist
(defun PutActiveStyleSheetToDefaultIfNotExistOrNone ()
(if (or (not
(member (GetActiveStyleSheet) (PlotStyleTableNamesList))
)
(= (GetActiveStyleSheet) "")
)
(PutActiveStyleSheet
(vla-get-DefaultPlotStyleTable
(vla-get-output
(vla-get-preferences (vlax-get-acad-object))
)
)
)
)
)
; Customize this as you want
; Either force the Plot Device and/or the Style Sheet to something
; or only if the saved setting doesn't exist.
; If the Plot Device (printer, plotter or PC3 file) saved in the drawing
; and that will be used when printing does not exist or is set to None
; set it instead to your default plotter/printer
(PutActivePlotDeviceToDefaultIfNotExistOrNone)
; If the Plot Style Table saved in the drawing
; and that will be used when printing does not exist or is set to None
; set it instead to your default plot style table
(PutActiveStyleSheetToDefaultIfNotExistOrNone)
; These below can be used if you want them set to None if they don't exists
;(PutActivePlotDeviceToNoneIfNotExist)
;(PutActiveStyleSheetToNoneIfNotExist)
; If you want to enforce another company standard you can
; activate and change in these functions
;(PutActivePlotDeviceToCompanyStandardIfNotExist)
;(PutActiveStyleSheetToCompanyStandardIfNotExist)
(princ)

     摘要: 本程序的功能：根据指定的坐标范围，计算所有处于该范围及相交于该范围边缘的将外部标准图幅的地形图，以块的形式按绝对坐标插入在当前指定图中。 包含的功能：指定外部标准图幅的地形图存放的路径，编制图幅对照表 定制界面： dlgdxtsslj : dialog {label = "数字图路径  [创建于2003.8]";   : boxed_column {label = ...  阅读全文      摘要: 自己从事的工作关系，利用autoCAD软件已经很多年了。 有时候，遇到一些很机械很机械的工作，总想着能不能用程序来帮帮忙。 于是，有一天就开始接触Lisp，翻翻相关的参考书，再看看别人的实例， 渐渐地，居然慢慢地就觉得开始有点上手。 之后，开始编写一些简单的功能，同时，不断的翻阅参考书， 了解其中的条理，熟悉了Liap语言的诸多函数命令。 到了一定地步，又有更野心的想法——编一个超大的...  阅读全文