常用函数.lsp

牛仔key

可以的没这么多的钱下载了，但是还是要支持下的

crazylsp

我把黄大侠的收集成果文章粘到word里添加了目录，方便查询。

etoxp

下下来看看

自贡黄明儒

;;152.1 [功能] 局部重生
;;152.2 [功能] 局部重生
;;153.1 [功能] 注册应用程序名的选择集
;;153.2 [功能] 一个图元的扩展数据列表
;;153.3 [功能] 一个图元的扩展数据列表(无注册应用程序名)
;;153.4 [功能] 一个图元的扩展数据列表
;;154.1 [功能] 获取ObjectDBX版本字符串
;;154.2 [功能] dwg转dxf文件函数
;;154.3 [功能] 将文件存为2K格式，并去教育版
;;154.4 [功能] 将文件以Wblock输出,并去教育版(文件名不变)
;;154.5 [功能] 打开的文件以Wblock输出,并去教育版(除激活的文档外,文件名不变)
;;154.6 [功能] 打开的文件全部Wblock输出

;;152.1 [功能] 局部重生 by Lee Mac
;;示例 (MJ:Update (entget (car (entsel))))
(defun MJ:Update (enlist)
  (entupd (cdr (assoc -1 enlist)))
)
;;152.2 [功能] 局部重生
;;示例(MJ:RedrawSS (ssget))
(defun MJ:RedrawSS (ss)
  (
   (lambda (i)
     (while (setq e (ssname ss (setq i (1+ i))))
       (entupd e)
     )
   )
    -1
  )  
)

;;153.1 [功能] 注册应用程序名的选择集
(defun ssget-app (rname)
  (ssget "X" (list (list -3 (list rname))))
)
;;153.2 [功能] 一个图元的扩展数据列表
;;示例 (get-eedlist-all (car (entsel)))
(defun get-eedlist-all (ent)
  (cdadr (assoc -3 (entget ent) '("*"))))
)
;;153.3 [功能] 一个图元的扩展数据列表(无注册应用程序名)
(defun getxdata-all (e apnlst)
  (apply 'append (mapcar 'cdr (getxdata e apnlst)))
)
;;153.4 [功能] 一个图元的扩展数据列表
(defun getxdata        (e apnlst)
  (cdr (assoc -3 (entget e apnlst)))
)

;;154.1 [功能] 获取ObjectDBX版本字符串
;;用于操作非打开文件
(defun GetObjectDBXVer (/ VERSION)
  (if (>= (setq VERSION (atoi (getvar "acadver"))) 16)
    (strcat "ObjectDBX.AxDbDocument." (itoa VERSION))
  )
)
;;154.2 [功能] dwg转dxf文件函数
;;非打开文件
(defun Dwg2Dxf (DwgName dxfName / dbxDoc)
  (setq        dbxDoc (vla-GetInterfaceObject
                 (vlax-get-acad-object)
                 (GetObjectDBXVer)
               )
  )
  (vla-open dbxDoc DwgName)                ;不能打开.dxf文件
  (vlax-invoke dbxDoc "dxfout" dxfName)
  (if dbxDoc
    (vlax-release-object dbxDoc)
  )                                        ;关闭文档,用(vla-close dbxDoc :vlax-false)行不通?
)
;;154.3 [功能] 将文件存为2K格式，并去教育版(文件名不变)
;;非打开的文件
;;(DwgOut "D:\\Drawing1.dwg")
(defun DwgOut (DwgName / BACKUPFILE BASENAME DOCOBJ DXFFILE FILEPATH)
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if        (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  ;;2 能删除所有文件，不管只读、隐藏与否，都能删除  
  (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
    (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
    (setq FILDIR (vl-filename-directory FIL))
    (setq
      SS (vl-directory-files
           FILDIR
           (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
           1
         )
    )
    (foreach ENT SS
      (vlax-invoke
        FILSYS
        "deletefile"
        (strcat FILDIR "\\" ENT)
        :vlax-false
      )
    )
    (vlax-release-object FILSYS)
  )
  ;;3 本程序主程序:1转成dxf 2原文件改名为备份 3打开另存为2K 4删除dxf
  (setq        BaseName   (vl-filename-base DwgName)
        filepath   (vl-filename-directory DwgName)
        dxfFile           (vl-string-subst ".dxf" ".dwg" DwgName)
        BackupFile (strcat (getfullpath filepath)
                           BaseName
                           "_Backup"
                           (vl-filename-extension DwgName)
                   )
  )
  (Dwg2Dxf DwgName dxfFile)                ;利用objectdbx转存文件,目的是去教育版印戳
  (if (findfile BackupFile)
    (deletefile BackupFile)
  )                                        ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
  (if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名
    (progn
      (setq
        DocObj (vla-open (vla-get-documents (vlax-get-acad-object))
                         dxfFile
               )
      )                                        ;打开dxf文件
      (vla-saveas DocObj DwgName acR15_DWG) ;再存为2k版dwg文件
      (vla-close DocObj :vlax-false)
      (deletefile dxfFile)                ;删除dxf文件
    )
  )
  (princ)
)
;;154.4 [功能] 将文件以Wblock输出,并去教育版(文件名不变)
;;非打开的文件
;;示例 (DwgOutWblock "D:\\Drawing1.dwg")
(defun DwgOutWblock
                    (DwgName        /           BACKUPFILE BASENAME
                     DOCOBJ        DXFFILE           FILEPATH   NEWSET
                     SSETS
                    )
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if        (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  ;;2 能删除所有文件，不管只读、隐藏与否，都能删除  
  (defun DeleteFile (FIL / FILSYS FILDIR SS ENT)
    (setq FILSYS (vlax-create-object "Scripting.FileSystemObject"))
    (setq FILDIR (vl-filename-directory FIL))
    (setq
      SS (vl-directory-files
           FILDIR
           (strcat (vl-filename-base FIL) (vl-filename-extension FIL))
           1
         )
    )
    (foreach ENT SS
      (vlax-invoke
        FILSYS
        "deletefile"
        (strcat FILDIR "\\" ENT)
        :vlax-false
      )
    )
    (vlax-release-object FILSYS)
  )
  ;;3 本程序主程序:1转成dxf 2原文件改名为备份 3打开并以wblock输出 4删除dxf
  (setq        BaseName   (vl-filename-base DwgName)
        filepath   (vl-filename-directory DwgName)
        dxfFile           (vl-string-subst ".dxf" ".dwg" DwgName)
        BackupFile (strcat (getfullpath filepath)
                           BaseName
                           "_Backup"
                           (vl-filename-extension DwgName)
                   )
  )
  (Dwg2Dxf DwgName dxfFile)                ;利用objectdbx转存文件,目的是去教育版印戳
  (if (findfile BackupFile)
    (deletefile BackupFile)
  )                                        ;检查原dwg文件的备份文件名是否存在，如果存在，则删除
  (if (vl-file-rename DwgName BackupFile) ;修改原dwg文件名
    (progn
      (setq
        DocObj (vla-open (vla-get-documents (vlax-get-acad-object))
                         dxfFile
               )
      )                                        ;打开dxf文件
      (setq ssets (vla-get-selectionsets DocObj))
      (if (vl-catch-all-error-p
            (vl-catch-all-apply 'vla-item (list ssets "$Set"))
          )
        (setq newSet (vla-add ssets "$Set"))
        (progn
          (vla-delete (vla-item ssets "$Set"))
          (setq newSet (vla-add ssets "$Set"))
        )
      )
      ;;select all objects in the drawing
      (vla-Select newSet acSelectionSetAll)
      (vla-WBlock DocObj DwgName newSet)
      (vla-close DocObj :vlax-false)
      (deletefile dxfFile)                ;删除dxf文件
    )
  )
  (princ)
)
;;154.5 [功能] 打开的文件以Wblock输出,并去教育版(除激活的文档外,文件名不变)
(defun DwgOutWblockOpen        (/ *ACAD* *DOCS* BASENAME CUR DWGNAME DWGNAMEEXT DWGNAMELIST FILEPATH N NEWDWGNAME SSOBJ)
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if        (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  
  (setq        *ACAD* (vlax-get-acad-object)
        *DOCS* (vla-get-Documents *ACAD*)
  )
  ;;2 打开的文件(除激活的文档外),全关闭,按非打开处理,再打开
  ;;DwgNameList除激活的文档外的打开文件列表,并关闭
  (vlax-for item *DOCS*
    (if        (= (vla-get-active item) :vlax-false)
      (progn (setq DwgName (vlax-get-property item 'FullName))
             (setq DwgNameList (cons DwgName DwgNameList))
             (vla-close item :vlax-false)
      )
      (setq cur item)
    )
  )
  (setq n -1)
  (repeat (length DwgNameList)
    (setq DwgName (nth (setq n (1+ n)) DwgNameList))
    (DwgOutWblock DwgName)
    (vla-open (vla-get-documents (vlax-get-acad-object)) DwgName)                                        ;再打开
  )
  ;;3 激活的文档须更名输出
  (setq DwgName (vlax-get-property cur 'FullName))
  (setq BaseName (vl-filename-base DwgName))
  (setq filepath (vl-filename-directory DwgName))
  (setq DwgNameExt (vl-filename-extension DwgName))
  (setq n -1)
  (while (findfile (setq NewDwgName
                          (strcat (getfullpath filepath)
                                  BaseName
                                  (itoa (setq n (1+ n)))
                                  DwgNameExt
                          )
                   )
         )
  )
  (ssget "x" (list (cons 410 (getvar "ctab"))))
  (setq SSOBJ (vla-get-activeselectionset cur))
  (vla-wblock cur NewDwgName SSOBJ)
  (DwgOutWblock NewDwgName)
  (vla-open (vla-get-documents (vlax-get-acad-object)) NewDwgName)
  (alert (strcat "\n 当前文档已经更名为" BaseName (itoa n)))
  (command "vbastmt" "AcadApplication.activeDocument.close false ")
)
;;154.6 [功能] 打开的文件全部Wblock输出
(defun OpenFileWblock (/ *ACAD* *DOCS* BASENAME DWGNAME DWGNAMEEXT EACH FILEPATH N NEWDWGNAME NEWSET SSETS J)
  ;;1 获取全路径，即路径后有
  (defun GetFullPath (path)
    (if        (wcmatch path "*\\")
      path
      (strcat path "\\")
    )
  )
  ;;2 打开的文件更名输出
  (setq *acad* (vlax-get-acad-object))
  (setq *DOCS* (vla-get-Documents *ACAD*))
  (setq n -1)
  (repeat (vlax-get-Property *DOCS* 'count)
    (setq each (vla-item *docs* (setq n (1+ n))))
    (setq DwgName (vlax-get-Property each 'fullname))
    (setq BaseName   (vl-filename-base DwgName)
          filepath   (vl-filename-directory DwgName)
          DwgNameExt (vl-filename-extension DwgName)
    )
    (setq J -1)
    (while (findfile (setq NewDwgName
                            (strcat (getfullpath filepath)
                                    BaseName
                                    (itoa (setq J (1+ J)))
                                    DwgNameExt
                            )
                     )
           )
    )
    (setq ssets (vla-get-selectionsets each))
    (if        (vl-catch-all-error-p
          (vl-catch-all-apply 'vla-item (list ssets "$Set"))
        )
      (setq newSet (vla-add ssets "$Set"))
      (progn
        (vla-delete (vla-item ssets "$Set"))
        (setq newSet (vla-add ssets "$Set"))
      )
    )
    ;;select all objects in the drawing
    (vla-Select newSet acSelectionSetAll)
    (vla-WBlock each NewDwgName newSet)
  )
  (princ)
)

cable2004

不错！完全学习。。。。。

Q1241274614

好程序！。。。。。。。。。。。。。

pxt2001

收集也是辛苦的劳动。

crtrccrt

一个字
很好

牛仔key

没钱下载了，但是支持楼主了

mycad

支持！！！！！！！！！！！！！！！！！！！！