[日积月累]：日积月累知识贴(禁止回复本贴)

wkai

获取 acad.exe 所在目录
[php](vla-get-path (vlax-get-acad-object))[/php]
获取文件搜索路径
[php]
(getvar "acadprefix")
[/php]
增加文件搜索路径
[php]
(defun PutSupportPath (Path)
  (vla-put-SupportPath
    (vla-get-Files
      (vla-get-Preferences
        (vlax-get-acad-object)
      )
    )
    (strcat (getvar "acadprefix") ";"Path)
  )
)
[/php]

Windows系统路径(mjtd)
[php]
(getenv "Windir")
[/php]

获取AUTOCAD的语言版本(mjtd)
英文=enu  简体=chs 繁体=cht
[php]
(getvar "LOCALE")
[/php]

aeo

打印机系列
[php]
; (setq ad (vla-get-activedocument (vlax-get-acad-object)))

;;所有的"图纸尺寸"定义
(defun GetCanonicalMediaNames (ad)
  (vla-RefreshPlotDeviceInfo
    (vla-get-activelayout ad))
  (vlax-safearray->list
    (vlax-variant-value
      (vla-GetCanonicalMediaNames
        (vla-item (vla-get-layouts ad) "Model"))))
)

;;"图纸尺寸"定义的本地名称
(defun GetLocaleMediaNames (ad / mn mnl)
  (setq la (vla-item (vla-get-layouts ad) "Model"))
  (foreach mn (GetCanonicalMediaNames ad)
    (setq mnl (cons (vla-GetLocaleMediaName la mn) mnl))
  )
  (reverse mnl)
)

;;所有的打印机设置.(设置，不是名称!)
(defun GetPlotDevices (ad)
  (vla-RefreshPlotDeviceInfo
    (vla-get-activelayout ad))
  (vlax-safearray->list
    (vlax-variant-value
      (vla-getplotdevicenames
        (vla-item (vla-get-layouts ad) "Model"))))
)

;;当前布局的当前打印机 :pc3
(defun GetActivePlotDevice (ad)
  (vla-get-ConfigName
    (vla-get-ActiveLayout ad))
)

;;当前设置下的"打印样式"  : ctb
(defun GetPlotStyleTableNames (ad)
  (vla-RefreshPlotDeviceInfo
    (vla-get-activelayout ad))
  (vlax-safearray->list
    (vlax-variant-value
      (vla-getplotstyletablenames
        (vla-item (vla-get-layouts ad) "Model"))))
)

;;所有的,(可能不会这么用)
(defun ListAllMediaNames(ad / al cn pd apmn)
  (setq al (vla-get-activelayout  ad))
  (setq cn (vla-get-configname al))
  (foreach pd (GetPlotDevices)
    (if (/= pd "None")
      (progn
        (vla-put-configname al pd)
        (setq apmn (cons pd apmn))
        (setq apmn (cons (GetCanonicalMediaNames ad) apmn))
      )
    )
  )
  (if (/= cn "None") (vla-put-configname al cn))
  (reverse apmn)
)

; (ListAllLocalMediaNames (vla-get-activedocument (vlax-get-acad-object)))
(defun ListAllLocalMediaNames(ad / al cn pd apmn)
  (setq al (vla-get-activelayout ad))
  (setq cn (vla-get-configname al))
  (foreach pd (GetPlotDevices ad)
    (if (/= pd "None")
      (progn
        (vla-put-configname al pd)
        (setq apmn (cons pd apmn))
        (setq apmn (cons (GetLocaleMediaNames ad) apmn))
      )
    )
  )
  (if (/= cn "None") (vla-put-configname al cn))
  (reverse apmn)
)

;;某一配置的"图纸尺寸"定义
; (GetCanonicalMediaNamesOfConfigname ad "Acrobat PDFWriter")
(defun GetCanonicalMediaNamesOfConfigname(ad cn / oldcn al cmn)
  (setq al (vla-get-ActiveLayout ad))
  (setq oldcn (vla-get-configname al))
  (vla-put-configname al cn)
  (vla-RefreshPlotDeviceInfo al)
  (setq cmn (GetCanonicalMediaNames ad))
  (if (/= oldcn "None") (vla-put-configname al oldcn))
  cmn
)

;;上面的本地名
; (GetLocalMediaNamesOfConfigname ad "Acrobat PDFWriter")
(defun GetLocalMediaNamesOfConfigname(ad cn / oldcn al cmn)
  (setq al (vla-get-ActiveLayout ad))
  (setq oldcn (vla-get-configname al))
  (vla-put-configname al cn)
  (vla-RefreshPlotDeviceInfo al)
  (setq cmn (GetLocaleMediaNames ad))
  (if (/= oldcn "None") (vla-put-configname al oldcn))
  cmn
)
[/php]
[php]
;;当前布局，下面有用.
(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 "Emtunga.pc3" to your need
(defun PutActivePlotDeviceToCompanyStandardIfNotExist ()
  (if (not (member (GetActivePlotDevice) (PlotDeviceNamesList)))
    (PutActivePlotDevice "Emtunga.pc3")
  )
)

; Change the Plot style table "Emtunga-A3-BW.ctb" to your need
(defun PutActiveStyleSheetToCompanyStandardIfNotExist ()
  (if (not (member (GetActiveStyleSheet) (PlotStyleTableNamesList)))
    (PutActiveStyleSheet "Emtunga-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))
        )
      )
    )
  )
)
[/php]

wkai :如果觉得不好，往下挪!

aeo

读幻灯片库里面的名称
返回名称的表
[php]
(defun read-slb->sldnames (path /
                           ex n id app appstr namestr nth1 nth2 nth3 nth4 nth5 chklist)
  (setq app nil n 0)
  (setq id (open path "r"))
  (read-line id)
  (setq ex (read-char id))
  (setq app (read-line id))
  (setq app (vl-remove 'nil (vl-string->list app)))
  (while (and (/= 101 (last app)) (read-char id) (setq ex (read-line id)))
    (setq app (append app (cons 1  (cons 1 (vl-remove 'nil (vl-string->list ex))))))
  )
  (close id)
  (setq app (cdr (cdr app )))
  (setq app (cons 1 (cons 1 app)))
  (foreach x app
    (cond
      ((and (< 0 x) (not nth1 )) (setq nth1 x))
      ((and nth1 (not nth2 )) (setq nth2 x))
      ((and nth2 (not nth3 )) (setq nth3 x))
      ((and nth3 (not nth4 )) (setq nth4 x))
      ((and nth4 (not nth5 )) (setq nth5 x))
    )
    (if (and nth1 nth2 nth3 nth4 nth5)
      (if (and (< 0 nth1) (< 0 nth2) (< 0 nth5)  (= 0 nth4))
        (if (/= x 0)
          (setq namestr (append namestr (list x)))
          (setq appstr (append appstr (list namestr))
                namestr nil
                nth1 nil nth2 nil nth3 nil nth4 nil nth5 nil
          )
        )
        (setq nth1 nil nth2 nil nth3 nil nth4 nil nth5 nil)
      )
    )
  )
  (acad_strlsort (mapcar 'vl-list->string appstr))
)
[/php]

aeo

在lisp编程中如何进行时间延迟控制

2. 
   
3. (defun WAIT (SECONDS / STOP)
   
4.   ;;
   
5.   ;; Posted by Tony Tanzillo
   
6.   ;; Creates a pause in your program flow
   
7.   ;; This function provides for much finer
   
8.   ;; increments in time then the command DELAY
   
9.   ;;
   
10.   (setq STOP (+ (getvar "DATE") (/ SECONDS 86400.0)))
    
11.   (while (> STOP (getvar "DATE"))
    
12.     (princ)
    
13.   )
    
14. )
    
15. ;;[i]2005年05月18日 by LUCAS  [/i]
    

<br /> (defun WAIT (SECONDS / STOP)<br />   ;;<br />   ;; Posted by Tony Tanzillo<br />   ;; Creates a pause in your program flow<br />   ;; This function provides for much finer<br />   ;; increments in time then the command DELAY<br />   ;;<br />   (setq STOP (+ (getvar "DATE") (/ SECONDS 86400.0)))<br />   (while (> STOP (getvar "DATE"))<br />     (princ)<br />   )<br /> )<br /> ;;[i]2005年05月18日 by LUCAS  [/i]<br />

aeo

删除 表中 相同项 的函数

2. 
   
3. (defun tt (ptlst / a lst)
   
4.   (while (setq a    (car ptlst)
   
5.            lst  (cons a lst)
   
6.            ptlst(vl-remove a ptlst))            
   
7.   )
   
8.   (reverse lst)
   
9. )
   
10. ;;[i]2005年05月19日 by 狂刀[/i]
    

<br /> (defun tt (ptlst / a lst) <br />   (while (setq a    (car ptlst) <br />            lst  (cons a lst) <br />            ptlst(vl-remove a ptlst))            <br />   ) <br />   (reverse lst) <br /> )<br /> ;;[i]2005年05月19日 by 狂刀[/i]<br />

2. 
   
3. ;;pts:表  fuzz:精度
   
4. ;;By Aeo
   
5. (defun lst-remove-dups(pts fuzz / pt x)
   
6. (cond ((=(length pts)1) pts)
   
7.        (t(setq pt(car pts))
   
8.          (cons pt(vl-remove-if '(lambda(x)(equal pt x fuzz))
   
9.                (lst-remove-dups(cdr pts)fuzz))
   
10.          )
    
11.      ))
    
12. )
    

<br /> ;;pts:表  fuzz:精度<br /> ;;By Aeo<br /> (defun lst-remove-dups(pts fuzz / pt x)<br /> (cond ((=(length pts)1) pts)<br />        (t(setq pt(car pts))<br />          (cons pt(vl-remove-if '(lambda(x)(equal pt x fuzz))<br />                (lst-remove-dups(cdr pts)fuzz))<br />          )<br />      ))<br /> )<br />