;;-------------------------------------------------------------------------------
;000fff
;日期：2016-09-05
;简介：AutoCAD和浩辰GCAD都能用的lisp小程序。
;文件名：mylisp20160113.lsp。
;可以替换该文件内容：C:\Gstarsoft\浩辰CAD电气2013\GRX8\OtherApp.lsp
;或者替换autocad中的C:\Program Files\AutoCAD 2005\Support\acad2005doc.lsp
; Next available MSG number is 104
; MODULE_ID ACAD2005doc_LSP_
;;; ACAD2005DOC.LSP Version 1.0 for AutoCAD 2005
;;;
;;; Copyright (C) 1994 - 2003 by Autodesk, Inc.
;;;
;;; 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.
;;;
;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
;;; 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.
;;;
;;;.
;;;
;;; Note:
;;; This file is loaded automatically by AutoCAD every time
;;; a drawing is opened. It establishes an autoloader and
;;; other utility functions.
;;;
;;; Globalization Note:
;;; We do not support autoloading applications by the native
;;; language command call (e.g. with the leading underscore
;;; mechanism.)
;;;===== Raster Image Support for Clipboard Paste Special =====
;;
;; IMAGEFILE
;;
;; Allow the IMAGE command to accept an image file name without
;; presenting the file dialog, even if filedia is on.
;; Example: (imagefile "c:/images/house.bmp")
;;
(defun imagefile (filename / filedia-save cmdecho-save)
(setq filedia-save (getvar "FILEDIA"))
(setq cmdecho-save (getvar "CMDECHO"))
(setvar "FILEDIA" 0)
(setvar "CMDECHO" 0)
(command "_.-image" "_attach" filename)
(setvar "FILEDIA" filedia-save)
(setvar "CMDECHO" cmdecho-save)
(princ)
)
;;;=== General Utility Functions ===
; R12 compatibility - In R12 (acad_helpdlg) was an externally-defined
; ADS function. Now it's a simple AutoLISP function that calls the
; built-in function (help). It's only purpose is R12 compatibility.
; If you are calling it for anything else, you should almost certainly
; be calling (help) instead.
(defun acad_helpdlg (helpfile topic)
(help helpfile topic)
)
(defun *merr* (msg)
(setq *error* m:err m:err nil)
(princ)
)
(defun *merrmsg* (msg)
(princ msg)
(setq *error* m:err m:err nil)
(princ)
)
;; Loads the indicated ARX app if it isn't already loaded
;; returns nil if no load was necessary, else returns the
;; app name if a load occurred.
(defun verify_arxapp_loaded (app)
(if (not (loadedp app (arx)))
(arxload app f)
)
)
;; determines if a given application is loaded...
;; general purpose: can ostensibly be used for appsets (arx) or (ads) or....
;;
;; app is the filename of the application to check (extension is required)
;; appset is a list of applications, (such as (arx) or (ads)
;;
;; returns T or nil, depending on whether app is present in the appset
;; indicated. Case is ignored in comparison, so "foo.arx" matches "FOO.ARX"
;; Also, if appset contains members that contain paths, app will right-match
;; against these members, so "bar.arx" matches "c:\\path\\bar.arx"; note that
;; "bar.arx" will *not* match "c:\\path\\foobar.arx."
(defun loadedp (app appset)
(cond (appset (or
;; exactly equal? (ignoring case)
(= (strcase (car appset))
(strcase app))
;; right-matching? (ignoring case, but assuming that
;; it's a complete filename (with a backslash before it)
(and
(> (strlen (car appset)) (strlen app))
(= (strcase (substr (car appset)
(- (strlen (car appset))
(strlen app)
)
)
)
(strcase (strcat "\\" app))
)
)
;; no match for this entry in appset, try next one....
(loadedp app (cdr appset)) )))
)
;;; ===== Single-line MText editor =====
(defun LispEd (contents / fname dcl state)
(if (not (setq fname (getvar "program")))
(setq fname "acad")
)
(strcat fname ".dcl")
(setq dcl (load_dialog fname))
(if (not (new_dialog "LispEd" dcl)) (exit))
(set_tile "contents" contents)
(mode_tile "contents" 2)
(action_tile "contents" "(setq contents $value)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "mtexted" "(done_dialog 2)" )
(setq state (start_dialog))
(unload_dialog dcl)
(cond
((= state 1) contents)
((= state 2) -1)
(t 0)
)
)
;;; ===== Discontinued commands =====
(defun c:ddselect(/ cmdecho-save)
(setq cmdecho-save (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "._+options" 7)
(setvar "CMDECHO" cmdecho-save)
(princ)
)
(defun c:ddgrips(/ cmdecho-save)
(setq cmdecho-save (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "._+options" 7)
(setvar "CMDECHO" cmdecho-save)
(princ)
)
(defun c:gifin ()
(alert "\n不再支持 GIFIN 命令。\n请使用 IMAGE 命令来附着光栅图像文件。\n")
(princ)
)
(defun c:pcxin ()
(alert "\n不再支持 PCXIN 命令。\n请使用 IMAGE 命令来附着光栅图像文件。\n")
(princ)
)
(defun c:tiffin ()
(alert "\n不再支持 TIFFIN 命令。\n请使用 IMAGE 命令来附着光栅图像文件。\n")
(princ)
)
(defun c:ddemodes()
(alert "“对象特性”工具栏包含了 DDEMODES 的功能。\nDDEMODES 已废弃。\n\n欲知详细信息，请从 AutoCAD 帮助的“索引”选项卡中选择“DDEMODES”。")
(princ)
)
(defun c:ddrmodes(/ cmdecho-save)
(setq cmdecho-save (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "._+dsettings" 0)
(setvar "CMDECHO" cmdecho-save)
(princ)
)
;;; ===== AutoLoad =====
;;; Check list of loaded <apptype> applications ("ads" or "arx")
;;; for the name of a certain appplication <appname>.
;;; Returns T if <appname> is loaded.
(defun ai_AppLoaded (appname apptype)
(apply 'or
(mapcar
'(lambda (j)
(wcmatch
(strcase j T)
(strcase (strcat "*" appname "*") T)
)
)
(eval (list (read apptype)))
)
)
)
;;
;; Native Rx commands cannot be called with the "C:" syntax. They must
;; be called via (command). Therefore they require their own autoload
;; command.
(defun autonativeload (app cmdliste / qapp)
(setq qapp (strcat "\"" app "\""))
(setq initstring "\n正在初始化...")
(mapcar
'(lambda (cmd / nom_cmd native_cmd)
(progn
(setq nom_cmd (strcat "C:" cmd))
(setq native_cmd (strcat "\"_" cmd "\""))
(if (not (eval (read nom_cmd)))
(eval
(read (strcat
"(defun " nom_cmd "()"
"(setq m:err *error* *error* *merrmsg*)"
"(if (ai_ffile " qapp ")"
"(progn (princ initstring)"
"(_autoarxload " qapp ") (command " native_cmd "))"
"(ai_nofile " qapp "))"
"(setq *error* m:err m:err nil))"
))))))
cmdliste)
nil
)
(defun _autoqload (quoi app cmdliste / qapp symnam)
(setq qapp (strcat "\"" app "\""))
(setq initstring "\n正在初始化...")
(mapcar
'(lambda (cmd / nom_cmd)
(progn
(setq nom_cmd (strcat "C:" cmd))
(if (not (eval (read nom_cmd)))
(eval
(read (strcat
"(defun " nom_cmd "( / rtn)"
"(setq m:err *error* *error* *merrmsg*)"
"(if (ai_ffile " qapp ")"
"(progn (princ initstring)"
"(_auto" quoi "load " qapp ") (setq rtn (" nom_cmd ")))"
"(ai_nofile " qapp "))"
"(setq *error* m:err m:err nil)"
"rtn)"
))))))
cmdliste)
nil
)
(defun autoload (app cmdliste)
(_autoqload "" app cmdliste)
)
(defun autoarxload (app cmdliste)
(_autoqload "arx" app cmdliste)
)
(defun autoarxacedload (app cmdliste / qapp symnam)
(setq qapp (strcat "\"" app "\""))
(setq initstring "\n正在初始化...")
(mapcar
'(lambda (cmd / nom_cmd)
(progn
(setq nom_cmd (strcat "C:" cmd))
(if (not (eval (read nom_cmd)))
(eval
(read (strcat
"(defun " nom_cmd "( / oldcmdecho)"
"(setq m:err *error* *error* *merrmsg*)"
"(if (ai_ffile " qapp ")"
"(progn (princ initstring)"
"(_autoarxload " qapp ")"
"(setq oldcmdecho (getvar \"CMDECHO\"))"
"(setvar \"CMDECHO\" 0)"
"(command " "\"_" cmd "\"" ")"
"(setvar \"CMDECHO\" oldcmdecho))"
"(ai_nofile " qapp "))"
"(setq *error* m:err m:err nil)"
"(princ))"
))))))
cmdliste)
nil
)
(defun _autoload (app)
; (princ "Auto:(load ") (princ app) (princ ")") (terpri)
(load app)
)
(defun _autoarxload (app)
; (princ "Auto:(arxload ") (princ app) (princ ")") (terpri)
(arxload app)
)
(defun ai_ffile (app)
(or (findfile (strcat app ".lsp"))
(findfile (strcat app ".exp"))
(findfile (strcat app ".exe"))
(findfile (strcat app ".arx"))
(findfile app)
)
)
(defun ai_nofile (filename)
(princ
(strcat "\n文件 "
filename
"(.lsp/.exe/.arx) 在搜索路径文件夹中未找到。"
)
)
(princ "\n请检查支持文件的安装，然后重试。")
(princ)
)
;;;===== AutoLoad LISP Applications =====
; Set help for those apps with a command line interface
(autoload "edge" '("edge"))
(setfunhelp "C:edge" "" "edge")
(autoload "3d" '("3d" "3d" "ai_box" "ai_pyramid" "ai_wedge" "ai_dome"
"ai_mesh" "ai_sphere" "ai_cone" "ai_torus" "ai_dish")
)
(setfunhelp "C:3d" "" "3d")
(setfunhelp "C:ai_box" "" "3d_box")
(setfunhelp "C:ai_pyramid" "" "3d_pyramid")
(setfunhelp "C:ai__wedge" "" "3d_wedge")
(setfunhelp "C:ai_dome" "" "3d_dome")
(setfunhelp "C:ai_mesh" "" "3d_mesh")
(setfunhelp "C:ai_sphere" "" "3d_sphere")
(setfunhelp "C:ai_cone" "" "3d_cone")
(setfunhelp "C:ai_torus" "" "3d_torus")
(setfunhelp "C:ai_dish" "" "3d_dish")
(autoload "3darray" '("3darray"))
(setfunhelp "C:3darray" "" "3darray")
(autoload "mvsetup" '("mvsetup"))
(setfunhelp "C:mvsetup" "" "mvsetup")
(autoload "attredef" '("attredef"))
(setfunhelp "C:attredef" "" "attredef")
(autoload "tutorial" '("tutdemo" "tutclear"
"tutdemo"
"tutclear"))
;;;===== AutoArxLoad Arx Applications =====
;;; ===== Double byte character handling functions =====
(defun is_lead_byte(code)
(setq asia_cd (getvar "dwgcodepage"))
(cond
( (or (= asia_cd "dos932")
(= asia_cd "ANSI_932")
)
(or (and (<= 129 code) (<= code 159))
(and (<= 224 code) (<= code 252))
)
)
( (or (= asia_cd "big5")
(= asia_cd "ANSI_950")
)
(and (<= 129 code) (<= code 254))
)
( (or (= asia_cd "gb2312")
(= asia_cd "ANSI_936")
)
(and (<= 161 code) (<= code 254))
)
( (or (= asia_cd "johab")
(= asia_cd "ANSI_1361")
)
(and (<= 132 code) (<= code 211))
)
( (or (= asia_cd "ksc5601")
(= asia_cd "ANSI_949")
)
(and (<= 129 code) (<= code 254))
)
)
)
;;; ====================================================
;;;
;;; FITSTR2LEN
;;;
;;; Truncates the given string to the given length.
;;; This function should be used to fit symbol table names, that
;;; may turn into \U+ sequences into a given size to be displayed
;;; inside a dialog box.
;;;
;;; Ex: the following string:
;;;
;;; "This is a long string that will not fit into a 32 character static text box."
;;;
;;; would display as a 32 character long string as follows:
;;;
;;; "This is a long...tatic text box."
;;;
(defun fitstr2len (str1 maxlen)
;;; initialize internals
(setq tmpstr str1)
(setq len (strlen tmpstr))
(if (> len maxlen)
(progn
(setq maxlen2 (/ maxlen 2))
(if (> maxlen (* maxlen2 2))
(setq maxlen2 (- maxlen2 1))
)
(if (is_lead_byte (substr tmpstr (- maxlen2 2) 1))
(setq tmpstr1 (substr tmpstr 1 (- maxlen2 3)))
(setq tmpstr1 (substr tmpstr 1 (- maxlen2 2)))
)
(if (is_lead_byte (substr tmpstr (- len (- maxlen2 1)) 1))
(setq tmpstr2 (substr tmpstr (- len (- maxlen2 3))))
(setq tmpstr2 (substr tmpstr (- len (- maxlen2 2))))
)
(setq str2 (strcat tmpstr1 "..." tmpstr2))
) ;;; progn
(setq str2 (strcat tmpstr))
) ;;; if
) ;;; defun
;;;
;;; If the first object in a selection set has an attached URL
;;; Then launch browser and point to the URL.
;;; Called by the Grips Cursor Menu
;;;
(defun C:gotourl ( / ssurl url i)
(setq m:err *error* *error* *merrmsg* i 0)
; if some objects are not already pickfirst selected,
; then allow objects to be selected
(if (not (setq ssurl (ssget "_I")))
(setq ssurl (ssget))
)
; if geturl LISP command not found then load arx application
(if (/= (type geturl) 'EXRXSUBR)
(arxload "achlnkui")
)
; Search list for first object with an URL
(while (and (= url nil) (< i (sslength ssurl)))
(setq url (geturl (ssname ssurl i))
i (1+ i))
)
; If an URL has be found, open browser and point to URL
(if (= url nil)
(alert "对象未关联统一资源定位符。")
(command "_.browser" url)
)
(setq *error* m:err m:err nil)
(princ)
)
;; Used by the import dialog to silently load a 3ds file
(defun import3ds (filename / filedia_old render)
;; Load Render if not loaded
(setq render (findfile "acRender.arx"))
(if render
(verify_arxapp_loaded render)
(quit)
)
;; Save current filedia & cmdecho setting.
(setq filedia-save (getvar "FILEDIA"))
(setq cmdecho-save (getvar "CMDECHO"))
(setvar "FILEDIA" 0)
(setvar "CMDECHO" 0)
;; Call 3DSIN and pass in filename.
(c:3dsin 1 filename)
;; Reset filedia & cmdecho
(setvar "FILEDIA" filedia-save)
(setvar "CMDECHO" cmdecho-save)
(princ)
)
;;;----------------------------------------------------------------------------
; New "Select All" function. Cannot be called transparently.
(defun c:ai_selall ( / ss old_error a b old_cmd old_hlt)
(setq a "CMDECHO" b "HIGHLIGHT"
old_cmd (getvar a) old_hlt (getvar b)
old_error *error* *error* ai_error)
(if (ai_notrans)
(progn
(princ "正在选择对象...")
(setvar a 0)
(setvar b 0)
(command "_.SELECT" "_ALL" "") ; Create Previous SS
(setvar a old_cmd)
(setvar b old_hlt)
(setq ss (ssget "_P"))
(sssetfirst ss ss) ; Non-gripped, but selected (someday!)
(princ "完成。\n")
)
)
(setq *error* old_error old_error nil ss nil)
(princ)
)
;;;
;;; Routines that check CMDACTIVE and post an alert if the calling routine
;;; should not be called in the current CMDACTIVE state. The calling
;;; routine calls (ai_trans) if it can be called transparently or
;;; (ai_notrans) if it cannot.
;;;
;;; 1 - Ordinary command active.
;;; 2 - Ordinary and transparent command active.
;;; 4 - Script file active.
;;; 8 - Dialogue box active.
;;;
(defun ai_trans ()
(if (zerop (logand (getvar "cmdactive") (+ 2 8) ))
T
(progn
(alert "不可以透明调用该命令。")
nil
)
)
)
(defun ai_transd ()
(if (zerop (logand (getvar "cmdactive") (+ 2) ))
T
(progn
(alert "不可以透明调用该命令。")
nil
)
)
)
(defun ai_notrans ()
(if (zerop (logand (getvar "cmdactive") (+ 1 2 8) ))
T
(progn
(alert "不可以透明调用该命令。")
nil
)
)
)
;;;----------------------------------------------------------------------------
; New function for invoking the product support help through the browser
(defun C:ai_product_support ()
(setq url "http://www.autodesk.com.cn/autocad-support")
(command "_.browser" url)
)
(defun C:ai_product_support_safe ()
(setq url "http://www.autodesk.com.cn/autocad-support")
(setq 404page "WSProdSupp404.htm")
(command "_.browser2" 404page url)
)
(defun C:ai_training_safe ()
(setq url "http://www.autodesk.com.cn/autocadlt-training")
(setq 404page "WSTraining404.htm")
(command "_.browser2" 404page url)
)
(defun C:ai_custom_safe ()
(setq url "http://www.autodesk.com/developautocad")
(setq 404page "WSCustom404.htm")
(command "_.browser2" 404page url)
)
;;-------------------------------------------------------------------------------
;000fff
;日期：2016-08-05
;简介：AutoCAD和浩辰GCAD都能用的lisp小程序。
;文件名：mylisp20160113.lsp。
;可以替换该文件内容：C:\Gstarsoft\浩辰CAD电气2013\GRX8\OtherApp.lsp
(defun OtherAppLoad (/)
(princ)
)
;--------------------
;FFF来进行指令提示。
(defun c:FFF()
(princ "指令：FFF:进行指令提示；J:各种线段合并成多段线；JJ:合并多条多段线；JK:测量线段长度；JKL:标注直线长度；zz:统计线段长度；KK:取消对象选择；K:文字编辑；HH:合并成单行文字；H:转换为当前图层；WFF:高级查找替换；BCC:CAD快速另存为新的文件；bccc:保存另存且关闭；rq:文字改为日期；ctt:插入时间和日期；"
)
)
;--------------------
;001、文件保存操作另存为新的文件
;==============================
;软件作者：百度用户：greatlmy
;软件更改者：百度用户：黑光计划
;如有需要请联系 企鹅代码：973490770
;==============================
;注意：另存为新的CAD文件快捷键“bcc”
;1.每次保存的文件名都会后缀一个时间字符串例如：
;“数据表-201607281430”
;表示2016年7月28号下午14点30分保存的文件。
;本程序要求CAD文件名的格式为【文件名+"-000000000000".dwg】，第一次保存后12个“0”会变成当前时间。
;2.时间精确到分钟，如果一分钟内执行多次保存操作，会替换同名文件而不产生新文件。
;3.该软件用来生成一系列的文件，
;如果计算机死机，你就可以根据后缀时间找到最近编辑的CAD文件。
;（CAD自动默认保存目录【开始】【运行】%temp%），我个人感觉不靠谱。
;下边是程序段。
;=====================================================
(defun c:bcc (/ sj fn n)
;快捷键bc
(command "qsave" )
(setq sj (getvar "cdate")
sj (* 10000 sj)
sj (rtos sj 2 0)
fn (strcat (getvar "DWGPREFIX") (getvar "DWGNAME"))
n (strlen fn)
fn (substr fn 1 (- n 17))
fn (strcat fn "-" sj ".dwg")
)
(command "saveas" "2004" fn )
(prompt "文件已经保存；并且另存为：")
(princ fn)
(princ)
)
;保存+另存+关闭三合一
(defun c:bccc (/ sj fn n)
;快捷键bc
(command "qsave" )
(setq sj (getvar "cdate")
sj (* 10000 sj)
sj (rtos sj 2 0)
fn (strcat (getvar "DWGPREFIX") (getvar "DWGNAME"))
n (strlen fn)
fn (substr fn 1 (- n 17))
fn (strcat fn "-" sj ".dwg")
)
(command "saveas" "2004" fn )
(prompt "文件已经保存；并且另存为：")
(princ fn)
(command "close" y )
(princ)
)
;======我是华丽分割线======================
;--------------------
;线条操作
;1、对多条直线或多段线进行混合，合并
(defun c:j(/ ss)
(prompt "合并直线和多线段等等。")
(setq ss (ssget))
(command "pedit" "m" ss "" "y" "j" "0" "")
)
;2、对多段线进行合并
(defun c:JJ(/ ss)
(prompt "合并多条多段线")
(setq ss (ssget))
(command "pedit" "m" ss "" "j" "0" "")
(print ss)
)
;3、量取直线、多段线、样条曲线、圆弧、圆、椭圆的长度
(defun c:jk()
(prompt "测量线段长度")
(setq cm (getvar "cmdecho"))
(setvar "cmdecho" 0)
(while (setq ent (car (entsel "\n选取多段线<回车结束>:")))
(setq dxf (entget ent)
nam (cdr (assoc 0 dxf))
)
(if (wcmatch nam "LINE,*POLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")
(progn
(command "_lengthen" ent "")
(setq cd (getvar "PERIMETER"))
(princ (strcat "\n所选取图元的长度为" (rtos cd 2 3)))
)
)
)
(setvar "cmdecho" cm)
(princ)
)
;4、统计选择线段的总长度。
(defun C:jkk (/ CURVE TLEN SS N SUMLEN)
(princ "程序：统计线段长度 命令：zz")
(vl-load-com)
(setq SUMLEN 0)
(setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC"))))
(setq N 0)
(repeat (sslength SS)
(setq CURVE (vlax-ename->vla-object (ssname SS N)))
(setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))
(setq SUMLEN (+ SUMLEN TLEN))
(setq N (1+ N)) )
(princ (strcat "\n共选择 " (itoa (sslength SS)) " 条线段. 线段总长: " (rtos SUMLEN 2 3) " .")))
;--------------------
;5标注线段长度
(defun c:jkl()
(prompt "测量线段长度")
(setq cm (getvar "cmdecho"))
(setvar "cmdecho" 0)
(while (setq ent (car (entsel "\n选取多段线<回车结束>:")))
(setq dxf (entget ent)
nam (cdr (assoc 0 dxf))
)
(if (wcmatch nam "LINE,*POLYLINE,SPLINE,ARC,CIRCLE,ELLIPSE")
(progn
(command "_lengthen" ent "")
(setq cd (getvar "PERIMETER"))
(setq cd (rtos (/ cd 1000) 2 3))
(princ (strcat "\n所选取图元的长度为" cd))
(setq pt (getpoint "\n请指定插入位置点: "))
(command "text" pt 100 0 cd )
)
)
)
(setvar "cmdecho" cm)
(princ)
)
---------------------
;选择操作
;1、取消对象选择
(defun c:KK()
(prompt "取消对象选择")
(command )
)
;--------------------
;文字操作
;单行文字对象编辑
(defun C:K(/ ss)
(princ "\n文字编辑")
(prompt "编辑天正文字")
(setq ss (ssget))
(command "T63_TObjedit" ss )
)
;合并成单行文字
(defun c:HH(/ SS)
(setq ss (ssget))
(command "IcTextMerge" ss "" "D")
)
;转换成当前图层
(defun c:H(/ ss)
(setq ss (ssget))
(command "LAYCUR" ss "")
)
;将文字改为日期
(defun c:rq(/ entn entl text high)
(setq entn (car (entsel "选择加年月日的文字")))
(setq entl (entget entn))
(setq ti (rtos (getvar "cdate") 2 6))
(setq yy (substr ti 3 2))
(setq mm (substr ti 5 2))
(setq mm (atoi mm))
(setq mm (itoa mm))
(setq dd (substr ti 7 2))
(setq dd (atoi dd))
(setq dd (itoa dd))
(setq text (strcat yy "/" mm "/" dd))
(setq entl (subst (cons 1 text) (assoc 1 entl) entl))
(entmod entl)
(princ)
)
;插入日期和时间
(defun C:ctt(/ pt date)
(setq pt (getpoint "\n请指定插入位置点: "))
(setq date (menucmd "M=$(edtime,$(getvar,date), YYYY年M月D日 hh:mm:ss)"))
(command "text" pt 1000 0 date)
)
;;*****************************************************************************
;;首先非常非常感谢原创作者：firstinti
;;http://bbs.mjtd.com/thread-93264-1-1.html
;;未完成的梦想：我想能够使CAD查找某个文字附近的某个其他文字。
;;如果有大神可以升级这个程序，请发到我的邮箱[email protected] ，拜托了
;;;****************************************************************************
;;;显示主对话框
;;;****************************************************************************
(defun xsdhk (/ replace )
(setq fn (open (setq lsdcl (VL-FILENAME-MKTEMP "tmp" "" ".dcl")) "w"))
(foreach x '(" czth : dialog{"
" label=\"查找替换 BY YJR111\";"
" :boxed_column {"
" label=\"查找替换\";"
" :row {"
" :popup_list{label=\"查找:\";key=\"18\";width=1;height = 2 ;}"
" :popup_list{label=\"替换:\";key=\"19\";width=1;height = 2 ;}"
" }"
" :row {"
" :edit_box{label=\"查找:\";key=\"oldword\";width = 34 ;height = 1.2 ;allow_accept=true;"
" }"
" :button{key=\"1\";label=\"拾取&Q>>\";width=1;height = 0.8 ;alignment=top;}"
" }"
" :row {"
" :edit_box{label=\"替换:\";key=\"newword\";width = 34.5 ;height = 1.2 ;allow_accept=true;"
" }"
" :button{key=\"2\";label=\"拾取&W>>\";width=1;height = 0.8 ;alignment=top;}"
" }"
" :row {"
" :text{value=\"范围:\";width=1;is_bold=true;}"
" :edit_box{key=\"6\";width=1;}"
" :button{key=\"7\";label=\"选择>\";width=1;}"
" :button{key=\"8\";label=\"全选&F \";width=12;}"
"}"
"}"
" :row {"
" :image{key=\"16\";height=0.2;}"
"}"
" :boxed_row {"
" label=\"查找结果\";"
" :column {"
" :list_box{key=\"9\";height=18;width=36;}"
"}"
" :column {"
" :button{key=\"10\";label=\"上一个&A\";width=1;height=2;}"
" :button{key=\"11\";label=\"下一个&S\";width=1;height=2;}"
" :button{key=\"12\";label=\"替 换&Z\";width=1;height=2;}"
" :button{key=\"3\";label=\"全部替换&Q\";width=15.5;height=2;}"
" :button{key=\"4\";label=\"全部亮显&D\";width=15.5;height=2;}"
" :button{key=\"14\";label=\"删除圆&E\";width=6;height=2;}"
" :button{key=\"15\";label=\"移 除&M\";width=6;height=2;}"
"}"
"}"
":row {"
":text{key=\"wxts\";is_bold=true;}"
"}"
":row{"
":toggle{key=\"tongtihuan\";label=\"固定&W\";width=1;height=2;}"
":edit_box{key=\"onerow\";width=34.2;height=1.4;allow_accept=true;}"
":button{key=\"xiugai\";label=\"修改&X\";width=1;height=2;}"
"}"
" :row {"
" :image{key=\"17\";height=0.2;}"
"}"
" :row {"
" :button{key=\"5\";label=\"选项...\";width=6;height=2;}"
" :image_button{color=3;height=2;key=\"color\";width=4;}"
" :edit_box"
" {"
" label=\"焦距\";"
" key=\"jiaoju\";"
" width = 1 ;"
" height = 1.2 ;"
" }"
" :button{key=\"cancel\";label=\"取消&C\";is_cancel=true;width=1;height=2;}"
" :button{key=\"13\";label=\"帮助&H\";width=1;height=2;}"
" }"
" :row {"
"label=\"焦距动态调节\";"
":slider{key=\"hdt\";value=10;min_value=0;max_value=1000;big_increment=10;small_increment=1;width=1;}"
" }"
"spacer_1;"
"}"
)
(write-line x fn)
)
(close fn)
(setq dclid (load_dialog lsdcl))
(vl-file-delete lsdcl)
(registryREAD);;;注意：读注册表要在对话框显示之前进行
(new_dialog "czth" dclid "" screenpt)
(if(and newch(/= newch ""))newch(setq newch "请输入替换字符串"))
(if(and oldch(/= oldch ""))oldch(setq oldch "请输入查找字符串"))
(if(= wqpp "1")(setq ppzfc oldch)(setq ppzfc (strcat "*" oldch "*")))
(or czls(setq czls "0"))
(or thls(setq thls "0"))
(or drcznr(setq drcznr "0"))
(or tcol(setq tcol 210))
(or tongtihuan(setq tongtihuan "0"))
(or screenpt(setq screenpt '(-1 -1)))
(or wxtsstr(setq wxtsstr "温馨提示:对话框可以移动至合适位置..."))
(and findlst(setq e(nth (atoi drcznr)findlst)))
(if(or(= re 7)(= re 8))(setq replace "0"))
(if (and e (= tongtihuan "0"))
(progn
(getetext)
(set_tile "onerow" etext)
(setq onerow etext)
)
(progn
(set_tile "onerow" newch)
(setq onerow newch)
)
)
(cond
((= re 7)
(setq fw "当前选择")
(setq drcznr "0")
)
((= re 8)
(setq fw "整个图形")
(setq drcznr "0")
)
(t (or fw(setq fw "")))
)
(drawdcl "16" 11)
(drawdcl "17" 11)
(cyczthsz)
(adlst "9" (mapcar 'caddr findlst))
(adlst "18" czstrlst)
(adlst "19" thstrlst)
(zhuangtai)
(c_img "color" tcol)
(set_tile
"color"
(cond ((= (strlen (itoa tcol)) 1) (strcat " " (itoa tcol)))
((= (strlen (itoa tcol)) 2) (strcat " " (itoa tcol)))
((= (strlen (itoa tcol)) 3) (strcat "" (itoa tcol)))
)
)
(set_tile "18" czls)
(set_tile "19" thls)
(set_tile "oldword" oldch)
(set_tile "newword" newch)
(set_tile "jiaoju" jiaoju)
(set_tile "tongtihuan" tongtihuan)
(set_tile "6" fw)
(set_tile "9" drcznr)
(set_tile "wxts" wxtsstr)
(action_tile "color" "(setq tcol (getcolordata tcol))(c_img $key tcol)")
(action_tile "oldword" "(setq oldch $value)(do1)")
(action_tile "newword" "(setq newch $value)(do2)")
(action_tile "jiaoju" "(linkhdt2jiaoju)")
(action_tile "1" "(setq screenpt(done_dialog 1))(wrscreept)")
(action_tile "2" "(setq screenpt(done_dialog 2))(wrscreept)")
(action_tile "3" "(setq screenpt(done_dialog 3))(do2)(wrscreept)")
(action_tile "4" "(setq screenpt(done_dialog 4))(wrscreept)")
(action_tile "5" "(option)")
(action_tile "6" "(setq fw $value)(getfw)")
(action_tile "7" "(setq screenpt(done_dialog 7))(wrscreept)")
(action_tile "8" "(setq screenpt(done_dialog 8))(wrscreept)")
(action_tile "9" "(setq rv1 $reason)(setq drcznr $value)
(if(= rv1 1)(do91))
(if(/= rv1 1)(progn(setq screenpt(done_dialog 9))(wrscreept)))")
(action_tile "10" "(setq up $value)(setq down \"0\")(do10)")
(action_tile "11" "(setq down $value)(setq up \"0\")(do10)")
(action_tile "12" "(setq replace $value)(setq up \"0\")(setq down \"1\")(tihuan findlst)(do2)")
(action_tile "13" "(helpmsg)")
(action_tile "14" "(done_dialog 14)")
(action_tile "15" "(do15)")
(action_tile "18" "(setq czls $value)(do18)")
(action_tile "19" "(setq thls $value)(do19)")
(action_tile "onerow" "(setq onerow $value)")
(action_tile "xiugai" "(xiugai)")
(action_tile "tongtihuan" "(setq tongtihuan $value)(if(= tongtihuan \"1\")(progn(setq onerow newch)(set_tile \"onerow\" newch))) ")
(action_tile "hdt" "(dohdt)")
(action_tile "cancel" "(done_dialog 0)")
(setq re (start_dialog))
(cond
((= re 0) (redraw4)(sssetfirst nil nil)(deleteyuan))
((= re 1) (shiqu))
((= re 2) (shiqu))
((= re 3) (tihuan findlst)(xsdhk))
((= re 4) (LIANGXIAN findlst))
((= re 7) (do7))
((= re 8) (do1)(do8))
((= re 9) (do9))
((= re 14) (deleteyuan2)(xsdhk))
)
(unload_dialog dclid)
);_ END xsdhk
;;;******************************************
;;;显示选项对话框
;;;******************************************
(defun option()
(setq fn (open (setq lsdcl (VL-FILENAME-MKTEMP "tmp" "" ".dcl")) "w"))
(foreach x '(" sz : dialog{"
" label=\"条件设置\";"
" :boxed_row {"
" :toggle"
" {"
" label=\"完全匹配 \";"
" key=\"wqpp\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" :toggle"
" {"
" label=\"区分大小写\";"
" key=\"qfdxx\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" }"
" :boxed_column {"
" :row {"
" :toggle"
" {"
" label=\"单行文字\";"
" key=\"dhwz\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" :toggle"
" {"
" label=\"多行文字\";"
" key=\"duohwz\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" }"
" :row {"
" :toggle"
" {"
" label=\"属性文字\";"
" key=\"sxwz\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" :toggle"
" {"
" label=\"天正文字\";"
" key=\"tzwz\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" }"
" :row {"
" :toggle"
" {"
" label=\"块内文字\";"
" key=\"knwz\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" :toggle"
" {"
" label=\"其他文字\";"
" key=\"tzqt\";"
" height = 1.2 ;"
" allow_accept=true;"
" }"
" }"
" }"
" :boxed_column {"
" label=\"历史记录设置(字符之间以空格分隔)\";"
" :edit_box{label=\"常用查找\";key=\"cycz\";width = 34 ;height = 1.2 ;allow_accept=true;}"
" :edit_box{label=\"常用替换\";key=\"cyth\";width = 34 ;height = 1.2 ;allow_accept=true;}"
"}"
" :row {"
" :toggle{label=\"清空查找结果\";key=\"qk\";}"
" ok_cancel;"
"}"
"}"
)
(write-line x fn)
)
(close fn)
(setq dclid (LOAD_DIALOG lsdcl))
(VL-FILE-DELETE lsdcl)
(registryREAD)
(new_dialog "sz" dclid )
(set_tile "wqpp" wqpp)
(set_tile "qfdxx" qfdxx)
(set_tile "dhwz" dhwz)
(set_tile "duohwz" duohwz)
(set_tile "sxwz" sxwz)
(set_tile "tzwz" tzwz)
(set_tile "knwz" knwz)
(set_tile "tzqt" tzqt)
(set_tile "cycz" cycz)
(set_tile "cyth" cyth)
(set_tile "qk" qk)
(action_tile "wqpp" "(setq wqpp $value)")
(action_tile "qfdxx" "(setq qfdxx $value)")
(action_tile "dhwz" "(setq dhwz $value)")
(action_tile "duohwz" "(setq duohwz $value)")
(action_tile "sxwz" "(setq sxwz $value)")
(action_tile "tzwz" "(setq tzwz $value)")
(action_tile "knwz" "(setq knwz $value)")
(action_tile "tzqt" "(setq tzqt $value)")
(action_tile "cycz" "(docycz)")
(action_tile "cyth" "(docyth)")
(action_tile "qk" "(setq qk $value)")
(action_tile "accept" "(done_dialog 100)")
(action_tile "cancel" "(done_dialog 0)")
(setq std(START_DIALOG))
(cond((= std 100)
(registrywrite)
)
)
(cyczthsz)
(unload_dialog dclid)
)
;;;***************************************************************
;;;常用查找替换字符串设置
;;;***************************************************************
(defun cyczthsz()
(if (and cycz (/= cycz ""))
(progn
(setq czcylst(str->lst cycz " "))
(foreach x czcylst
(if (and x(not(member x czstrlst)))
(setq czstrlst(cons x czstrlst))
)
)
(adlst "18" czstrlst)
(set_tile "18" "0")
(set_tile "oldword" (car czstrlst))
)
)
(if (and cyth (/= cyth ""))
(progn
(setq thcylst(str->lst cyth " "))
(foreach x thcylst
(if (and x(not(member x thstrlst)))
(setq thstrlst(cons x thstrlst))
)
)
(adlst "19" thstrlst)
(set_tile "19" "0")
(set_tile "newword" (car thstrlst))
)
)
)
;;;******************************************
;;;定义e
;;;******************************************
(defun gete()
(setq e(nth (atoi drcznr)findlst))
)
;;;******************************************
;;;定义etext
;;;******************************************
(defun getetext()
(setq etext (substr (caddr e)(1+(strlen(strcat"["(itoa(1+(atoi drcznr)))"] ")))))
)
;;;**********************************************
;;;字符串转表
;;;str:字符串 sign字符串分割标记，例如"1 2 3 4"->("1" "2" "3" "4")
;;;**********************************************
(defun str->lst(str sign / position lst)
(while (and str(/= str ""))
(if(setq position (vl-string-search sign str))
(progn
(setq lst (append lst (list (substr str 1 position))))
(setq str (substr str (+ 2 position)))
)
(progn
(setq lst (append lst (list str )))
(setq str nil)
)
)
)
lst
)
;|选择集筛选函数 by firstinti
http://bbs.mjtd.com/thread-93264-1-1.html
ss-原始总选择集
vartxtlst-各分类选择集变量名列表
filterlst-各分类选择集类型
(setq ss (ssget))
(setq vartxtlst (list "ss1" "ss2" "ss3")
filterlst (list "circle" "*line" "*text")
)
用法:(ssgflt ss vartxtlst filterlst)
|;
(defun ssgflt(ss vartxtlst filterlst)
(defun wmg-ssgetp (ss filter)
(if ss(vl-cmdf "select" ss ""))
(ssget "p" (list (cons 0 filter)))
)
(mapcar (function (lambda (x y) (set x (wmg-ssgetp ss y))))
(mapcar 'read vartxtlst)
filterlst
)
)
;;;**********************************************
;;;写注册表对话框位置
;;;**********************************************
(defun wrscreept()
(and screenpt(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "screenpt" (vl-princ-to-string screenpt)))
)
;;;**********************************************
;;;写注册表选项配置
;;;**********************************************
(defun registrywrite()
(and wqpp(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "wqpp" wqpp))
(and qfdxx(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "qfdxx" qfdxx))
(and dhwz(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "dhwz" dhwz))
(and duohwz(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "duohwz" duohwz))
(and sxwz(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "sxwz" sxwz))
(and tzwz(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "tzwz" tzwz))
(and knwz(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "knwz" knwz))
(and tzqt(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "tzqt" tzqt))
(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "cycz" cycz)
(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "cyth" cyth)
(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "qk" qk)
)
;;;**********************************************
;;;读注册表选项配置
;;;**********************************************
(DEFUN registryREAD()
(or (setq wqpp (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "wqpp"))(setq wqpp "0"))
(or (setq qfdxx (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "qfdxx"))(setq qfdxx "0"))
(or (setq dhwz (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "dhwz"))(setq dhwz "1"))
(or (setq duohwz (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "duohwz"))(setq duohwz "1"))
(or (setq sxwz (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "sxwz"))(setq sxwz "0"))
(or (setq tzwz (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "tzwz"))(setq tzwz "0"))
(or (setq knwz (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "knwz"))(setq knwz "0"))
(or (setq tzqt (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "tzqt"))(setq tzqt "0"))
(or (setq cycz (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "cycz"))(setq cycz ""))
(or (setq cyth (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "cyth"))(setq cyth ""))
(or (setq qk (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "qk"))(setq qk "0"))
(or (setq jiaoju (vl-registry-read "HKEY_CURRENT_USER\\czthoption" "jiaoju"))(setq jiaoju "10"))
(if(setq screenpt(vl-registry-read "HKEY_CURRENT_USER\\czthoption" "screenpt"))
(setq screenpt (read(vl-registry-read "HKEY_CURRENT_USER\\czthoption" "screenpt")))
(setq screenpt '(-1 -1))
)
)
;;;**************************************************
;;;状态显示
;;;**************************************************
(defun zhuangtai()
(IF FINDLST
(PROGN
(MODE_TILE "3" 0)
(MODE_TILE "4" 0)
(MODE_TILE "10" 0)
(MODE_TILE "11" 0)
(MODE_TILE "12" 0)
(MODE_TILE "15" 0)
(MODE_TILE "hdt" 0)
(MODE_TILE "xiugai" 0)
)
(PROGN
(MODE_TILE "3" 1)
(MODE_TILE "4" 1)
(MODE_TILE "10" 1)
(MODE_TILE "11" 1)
(MODE_TILE "12" 1)
(MODE_TILE "15" 1)
(MODE_TILE "hdt" 1)
(MODE_TILE "xiugai" 1)
)
)
(if (ssget "x" (list (cons 0 "ellipse") (cons 8 "findttz")))
(MODE_TILE "14" 0)
(MODE_TILE "14" 1)
)
(mode_tile "6" 1)
)
;;;**************************************************
;;;常用查找历史记录设置
;;;**************************************************
(defun docycz()
(setq cycz $value)
)
;;;**************************************************
;;;常用替换历史记录设置
;;;**************************************************
(defun docyth()
(setq cyth $value)
)
;;;**************************************************
;;;屏幕提取文字
;;;**************************************************
(defun shiqu(/ ent1 enttext s )
(setq ent1 (nentsel"\n请点击文字提取:"))
(if (and ent1(wcmatch(cdr(assoc 0 (setq s(entget (car ent1)))))"*TEXT,ATTREF,ATTRIB"))
(progn
(setq enttext (cdr (assoc 1 s)))
(if (= re 1)(setq oldch enttext))
(if (= re 2)(setq newch enttext))
)
)
(xsdhk)
)
;;;******************************************
;;;在DCL上画画
;;;******************************************
(defun drawdcl(key dclcol / n)
(setq width (dimx_tile key)
height (dimy_tile key)
)
(start_image key)
(vector_image 0 0 width 0 dclcol)
(vector_image 0 0 0 height dclcol)
(vector_image 0 height width height dclcol)
(vector_image width height width 0 dclcol)
(vector_image width 0 0 0 dclcol)
(fill_image 0 0 width height dclcol)
(end_image)
)
;;;******************************************
;;;获取cad标准颜色
;;;******************************************
(defun getcolordata(col / ccc)
(setq ccc(acad_colordlg col t))
(if (not ccc)(setq ccc col))
ccc
)
;;;******************************************
;;;初始化颜色图像按钮
;;;******************************************
(defun c_img(key col)
(if col
(progn
(start_image key)
(fill_image 0 0 (dimx_tile key)(dimy_tile key)col)
(end_image)
(set_tile "color" (cond((=(strlen(itoa col))1)(strcat " "(itoa col)))
((=(strlen(itoa col))2)(strcat " "(itoa col)))
((=(strlen(itoa col))3)(strcat ""(itoa col)))
)
)
)
)
)
;;;******************************************
;;;温馨提示
;;;******************************************
(defun wxts()
(alert wxts)
)
;;;******************************************
;;;删除椭圆
;;;******************************************
(defun deleteyuan()
(if (setq elliss(ssget "x" (list(cons 0 "ellipse,circle")(cons 8 "findttz"))))
(repeat (setq n (sslength elliss))
(vla-delete (vlax-ename->vla-object (ssname elliss (setq n(1- n)))))
)
)
)
;;;******************************************
;;;删除椭圆2
;;;******************************************
(defun deleteyuan2()
(deleteyuan)
(vla-ZoomScaled myacad 1 acZoomScaledRelative)
(vla-zoomprevious myacad)
)
;;;******************************************
;;;暗显图元
;;;******************************************
(DEFUN REDRAW4()
(IF FINDLST
(PROGN
(vl-remove-if '(LAMBDA(X)(VLA-HIGHLIGHT X :VLAX-FALSE))(MAPCAR 'CADR FINDLST))
)
)
)
;;;******************************************
;;;添加列表框内列表
;;;******************************************
(defun adlst(key lst);;;仅对popup_list或list_box有效
(start_list key 3);;;处理列表开始
(mapcar 'add_list lst)
(end_list);;;添加列表结束
)
;;;******************************************
;;;滑动条动作函数
;;;******************************************
(defun dohdt ()
(set_tile "jiaoju" $value)
(setq jiaoju $value)
(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "jiaoju" jiaoju)
(gete)
(getetext)
(zoome e)
)
;;;******************************************
;;;滑动条链接焦距编辑框函数
;;;******************************************
(defun linkhdt2jiaoju(/ num)
(setq num (atof $value))
(if(or (< num -10000)(> num 10000))
(progn
(if (< num 0) (alert"\n请大于-10000..."))
(if (> num 10000)(alert"\n请小于10000..."))
(set_tile $key (get_tile "hdt" ))
(setq jiaoju (atof $value))
(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "jiaoju" jiaoju)
)
(progn
(set_tile "hdt" (rtos num 2 1))
(setq jiaoju (rtos num 2 1))
(vl-registry-write "HKEY_CURRENT_USER\\czthoption" "jiaoju" jiaoju)
)
)
)
;;;****************************************************
;;;普通文字画椭圆包围框
;;;*****************************************************
(defun getbox(obj / inserp )
(if (assoc "B" (LIST E))
(PROGN
(SETQ MIDP (NTH 3 E)
minp (NTH 4 E)
MAXP (NTH 5 E)
)
(EMAKECR midp MINP tcol etext)
)
(PROGN
(if(not(vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox(list obj 'minp 'maxp))))
(progn
(setq minp (vlax-safearray->list minp)
maxp (vlax-safearray->list maxp)
midp (polar minp (angle minp maxp) (/ (distance minp maxp) 2))
)
(EMAKEEL midp MINP tcol etext)
)
)
)
)
(VLA-HIGHLIGHT OBJ :VLAX-TRUE)
(REDRAW (ENTLAST) 3)
)
;;;******************************************
;;;聚焦对象
;;;******************************************
(defun zoome(e)
(deleteyuan)
(getetext)
(setq txtang (last e))
(getbox (cadr e))
(setq objlast (VLAX-ENAME->VLA-OBJECT (entlast)))
(if (/= txtang 0.0) (vla-rotate objlast(vlax-3d-point midp)txtang))
(vla-highlight objlast :vlax-true)
(vla-zoomwindow myacad (vlax-3d-point(MAPCAR '(LAMBDA(X Y)(- X Y))minp (list(* (distof jiaoju) 100) (* (distof jiaoju) 100))))
(vlax-3d-point(MAPCAR '(LAMBDA(X Y)(+ X Y))maxp (list(* (distof jiaoju) 100) (* (distof jiaoju) 100)))))
)
;;;******************************************
;;;查找编辑框动作函数
;;;******************************************
(defun do1()
(if(and(/= oldch "输入查找字符串")(not(member oldch czstrlst)))
(progn
(setq czstrlst(cons oldch czstrlst))
(adlst "18" czstrlst)
(set_tile "18" "0")
)
)
)
;;;******************************************
;;;替换编辑框动作函数
;;;******************************************
(defun do2()
(if(and(/= newch "输入替换字符串")(not(member newch thstrlst)))
(progn
(setq thstrlst(cons newch thstrlst))
(adlst "19" thstrlst)
(set_tile "19" "0")
)
)
)
;;;******************************************
;;;选择动作
;;;******************************************
(defun do7()
(sssetfirst nil nil)
(select)
(setq findlst nil sstxt nil )
(getss)
(LIANGXIAN findlst)
(xsdhk)
)
;;;******************************************
;;;设置选择范围状态值（显示值）
;;;******************************************
(defun do8()
(setq findlst nil sstxt nil )
(getfw)
(getss)
(LIANGXIAN findlst)
(xsdhk)
)
;;;******************************************
;;;列表框动作程序
;;;******************************************
(defun do91()
;;; (setq e(nth (atoi drcznr)findlst))
(gete)
(if e
(progn
(getetext)
(redraw4)
(zoome e)
(setq wxtsstr (strcat (itoa(1+(atoi drcznr))) "\/" (itoa (length findlst))" 当前文本:" etext))
(set_tile "wxts" wxtsstr)
(if (= tongtihuan "0")
(progn
(set_tile "onerow" etext)
(setq onerow etext)
)
)
)
)
)
(defun do9()
(gete)
(LIANGXIAN (list e))
(redraw4)
(zoome e)
(princ"\n任意键返回对话框!!!")
(while (and
(/= 2 (setq a(car (grread))))
(/= a 3)
(/= a 11)
(/= a 25)
)
)
(vla-delete (vlax-ename->vla-object(entlast)))
(xsdhk)
)
;;;******************************************
;;;上一个缩放和下一个缩放
;;;******************************************
(defun do10(/ )
(deleteyuan)
(cond
((=(type drcznr) 'str)
(if (= up "1")(setq drcznr(itoa(1-(atoi drcznr))))(setq drcznr(itoa(1+(atoi drcznr)))))
)
((=(type drcznr) 'int)
(if (= up "1")(setq drcznr(itoa(1- drcznr)))(setq drcznr(itoa(1+ drcznr))))
)
)
(setq endnum(length findlst))
(cond
((and(<(atoi drcznr)0)(= up "1"))
(setq drcznr (itoa (1- endnum)))
)
((and(>=(atoi drcznr)endnum)(= down "1"))
(setq drcznr "0")
)
)
(set_tile "9" drcznr)
(if (and findlst (gete))
(progn
(getetext)
(zoome e)
(setq wxtsstr (strcat (itoa(1+(atoi drcznr))) "\/" (itoa (length findlst))" 当前文本:" etext))
(set_tile "wxts" wxtsstr)
(if (= tongtihuan "0")
(progn
(set_tile "onerow" etext)
(setq onerow etext)
)
)
)
)
)
;;;******************************************
;;;移除列表框内列表项
;;;******************************************
(defun do15(/ )
(setq endnum(length findlst))
(if (and findlst (> endnum 0)(<(atoi drcznr) endnum))
(progn
(setq findlst (vl-remove (setq e(nth (atoi drcznr) findlst))findlst))
(getetext)
(if findlst
(progn
(setq j 0)
(setq findlst(mapcar '(lambda(x)(setq j(1+ j))
(setq ex(substr (caddr x) (+ 2(vl-string-search " " (caddr x)))))
(append (list(car x)(cadr x)(strcat "["(itoa j)"] "ex))(cdddr x)))
findlst)
)
)
)
(adlst "9" (mapcar 'caddr findlst))
(setq endnum(length findlst))
(cond
((>(atoi drcznr)0)
(setq drcznr (itoa (- (atoi drcznr) 1)))
)
)
(set_tile "9" drcznr)
(if findlst
(if(= (atoi drcznr)endnum)
(setq wxtsstr (strcat drcznr "\/" (itoa (length findlst))" 移除文本:" etext))
(setq wxtsstr (strcat (itoa(1+ (atoi drcznr))) "\/" (itoa (length findlst))" 移除文本:" etext))
)
(progn
(setq wxtsstr (strcat drcznr "\/" (itoa (length findlst))" 移除文本:" etext))
(MODE_TILE "3" 1)
(MODE_TILE "4" 1)
(MODE_TILE "10" 1)
(MODE_TILE "11" 1)
(MODE_TILE "12" 1)
(MODE_TILE "15" 1)
(MODE_TILE "hdt" 1)
(MODE_TILE "xiugai" 1)
)
)
(set_tile "wxts" wxtsstr)
)
)
)
;;;****************************************************
;;;查找历史记录列表框动作
;;;*****************************************************
(defun do18()
(setq oldch (nth (atoi $value) czstrlst))
(set_tile "oldword" oldch)
)
;;;****************************************************
;;;替换历史记录列表框动作
;;;*****************************************************
(defun do19()
(setq newch (nth (atoi $value) thstrlst))
(set_tile "newword" newch)
)
;;;****************************************************
;;;画椭圆
;;;*****************************************************
(DEFUN EMAKEEL(p11 p10 col txt)
(entmake (list '(0 . "ELLIPSE") '(100 . "AcDbEntity")'(100 . "AcDbEllipse")(cons 10 p11)
(cons 11 (list (* 1.3 (eval(cons 'max (list(- (car p11)(car p10))(- (cadr p11)(cadr p10))))))0.0 0.0))(cons 8 "findttz")(cons 62 col)
(cons 40 (/ 1 (* 0.45(if (>(strlen txt)4)(strlen txt)4))))'(41 . 0)'(42 . 6.28319)
)
)
)
;;;****************************************************
;;;画圆
;;;*****************************************************
(DEFUN EMAKECR(p11 p10 col txt)
(entmake (list '(0 . "CIRCLE") '(100 . "AcDbEntity")(cons 10 p11)
(cons 40 (eval(cons 'max (list(- (car p11)(car p10))(- (cadr p11)(cadr p10))))))(cons 8 "findttz")(cons 62 col)
)
)
)
;;;******************************************
;;;整行修改
;;;******************************************
(defun xiugai()
(if findlst
(progn
(gete)
(setq obj (cadr e))
(setq textqz(substr (caddr e) 1 (1+ (setq j(vl-string-search " " (caddr e))))))
(getetext)
(zoome e)
(if (assoc "B" (list e))
(progn
(divss findlst)
(repeat (setq knum(length kuaitext))
(if (not(member (setq blkname(vla-get-name(car(nth (setq knum(1- knum))kuaitext))))blklst))
(setq blklst(cons blkname blklst))
)
)
(vlax-for blk (vla-get-blocks(setq mydoc(vla-get-activedocument(vlax-get-acad-object))))
(if (member (setq blkname(vla-get-name blk))blklst)
(progn
(SETQ NN 0)
(repeat (vla-get-count blk)
(if(and(or(= "AcDbText" (vla-get-objectname (setq oldobj(vla-item blk NN))))
(= "AcDbMText" (vla-get-objectname (setq oldobj(vla-item blk NN))))
)
)
(progn
(if (and(=(car(nth (atoi drcznr)findlst))"B")(= blkname (vla-get-name(cadr(nth (atoi drcznr)findlst)))))
(progn
(setq thknum 0)
(vla-put-textstring oldobj onerow)
(vla-update oldobj)
(setq thknum(sslength(SETQ BLKSS(ssget "X"(list (cons 0 "insert")(cons 2 blkname))))) MM 0)
(REPEAT thknum
(vla-update (VLAX-ENAME->VLA-OBJECT(SSNAME BLKSS MM)))
(SETQ MM(1+ MM))
)
(MAPCAR '(LAMBDA(x)
(if (and (= (car x) "B")(= (vla-get-name (cadr x)) blkname))
(progn
(setq findlst (subst (list "B" (NTH 1 x) (strcat textqz ONEROW) (NTH 3 x)(NTH 4 x)(NTH 5 x)) x findlst))
(setq thknum (1+ thknum))
)
)
)
findlst
)
(adlst "9" (mapcar 'caDdr findlst))
(setq wxtsstr (strcat "块名:" blkname "文本"etext"改为"onerow"..." "共更新块参照" (itoa thknum)"个"))
(set_tile "wxts" wxtsstr)
)
)
)
)
(setq nn(1+ nn))
)
)
)
)
)
(progn
(vla-put-textstring obj onerow)
(vla-update obj);;;更新查找的字符串
(setq findlst (subst (append (list (car e)obj (strcat textqz onerow)) (cdddr e))e findlst))
(adlst "9" (mapcar 'caddr findlst));;;更新查找结果列表
(set_tile "9" (setq drcznr(itoa(if(<(1+(atoi drcznr))(length findlst))(1+(atoi drcznr)) 0))))
(setq wxtsstr (strcat etext "已经修改为" onerow))
)
)
(set_tile "wxts" wxtsstr)
(if (= tongtihuan "0")
(progn
(gete)
(set_tile "onerow" (getetext))
(setq onerow etext)
)
)
)
)
)
;;;*********************************************
;;;范围选择
;;;*********************************************
(defun select()
(if(= wqpp "1")(setq ppzfc oldch)(setq ppzfc (strcat "*" oldch "*")))
(setq js1 0 js2 0 js3 0)
(PROMPT"\n选择查找替换范围:")
(setvar 'nomutt 1)
(if (or (= sxwz "1")(= knwz "1"))
(setq ss (ssget (list '(-4 . "<or")(cons 0 "INSERT")
'(-4 . "<and")(cons 0 "TEXT,MTEXT,TCH_*TEXT,TCH_DRAWINGNAME")
'(-4 . "<or")(cons 1 ppzfc)(cons 1 (strcase ppzfc))'(-4 . "or>")
'(-4 . "and>")
'(-4 . "or>"))))
(setq ss (ssget (list (cons 0 "TEXT,MTEXT,TCH_*TEXT,TCH_DRAWINGNAME")'(-4 . "<or")(cons 1 ppzfc)(cons 1 (strcase ppzfc))'(-4 . "or>"))))
)
(setq oldss ss)
)
;;;******************************************
;;;取得全部选择范围状态下选择集
;;;******************************************
(defun getfw()
(if(= wqpp "1")(setq ppzfc oldch)(setq ppzfc (strcat "*" oldch "*")))
(if (= re 8)
(progn
(if(or (= sxwz "1")(= knwz "1"))
(setq ss (ssget "X"(list '(-4 . "<or")(cons 0 "INSERT")
'(-4 . "<and")(cons 0 "TEXT,MTEXT,TCH_*TEXT,TCH_DRAWINGNAME")
'(-4 . "<or")(cons 1 ppzfc)(cons 1 (strcase ppzfc))'(-4 . "or>")
'(-4 . "and>")
'(-4 . "or>")))
)
(setq ss (ssget "X"(list
(cons 0 "TEXT,MTEXT,TCH_*TEXT,TCH_DRAWINGNAME")
'(-4 . "<or")(cons 1 ppzfc)(cons 1 (strcase ppzfc))'(-4 . "or>"))
)
)
)
(setq oldss ss)
)
(setq ss oldss)
)
)
;;;****************************************************
;;;;;;组成新字符串
;;;*****************************************************
(defun getnewtext(etext)
(setq pos(vl-string-search (if (= qfdxx "0")(strcase oldch)oldch)
(if (= qfdxx "0")(strcase etext)etext))
)
(if pos
(setq newtext(strcat (substr etext 1 pos)newch(substr etext (+ 1 pos (strlen oldch)))))
(setq newtext etext)
)
)
;;;****************************************************
;;;;;;变换矩阵
;;;****************************************************
(defun M_REV (A / N U V)
(setq N 0)
(repeat (length A)
(setq U (cons (mapcar '(lambda (V) (nth N V)) A) U)
N (1+ N)
)
)
(reverse U)
)
;;;***********************************************************
;;; 获取块内非块实体
;;;***********************************************************
(defun ayGetAllEntInBLK(entBlkName / xBlkName xBlkDef entName1 entType tmx xinserp minp maxp midp )
(SETQ xinserp(cdr (assoc 10 (entget entBlkName))));;;嵌套块插入点
(SETQ xBlkName(cdr (assoc 2 (entget entBlkName))));;;嵌套块名
(SETQ oldobj(vlax-ename->vla-object entBlkName));;;嵌套块vla对象
(setq kuaiang(cdr (assoc 50 (entget entBlkName))));;;块的旋转角度
(setq xBlkDef (tblobjname "Block" xBlkName))
(if (equal xinserp oldinserp)
(setq tmx oldinserp)
(progn
(setq tmx (mapcar '(lambda(x y)(+ x y))oldinserp xinserp))
(setq oldinserp tmx)
)
)
(while (setq entName1 (entnext xBlkDef))
(setq entType (cdr (assoc 0 (entget entName1))));;;子图元类型
(SETQ xoldobj(vlax-ename->vla-object entName1));;;子图元vla对象
(if(= entType "INSERT")
(progn
(ayGetAllEntInBLK entName1);;;递归
(grtext -2 (strcat "正在搜索块内文字,请耐心等候" (nth biaojinum biaoji)))
(if (< biaojinum 8)(setq biaojinum (1+ biaojinum))(setq biaojinum 0))
)
(IF (AND(OR(= "AcDbText" (vla-get-objectname xoldobj))
(= "AcDbMText" (vla-get-objectname xoldobj))
(= "AcDbAttributeDefinition" (vla-get-objectname xoldobj))
(= "AcDbAttribute" (vla-get-objectname xoldobj))
)
(setq etext(vla-get-textstring xoldobj))
(wcmatch (if (= qfdxx "0") (strcase etext )etext)(if (= qfdxx "0")(strcase ppzfc )ppzfc))
)
(PROGN
(if(not(vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox(list xoldobj 'minp 'maxp))))
(progn
(setq minp (vlax-safearray->list minp)
maxp (vlax-safearray->list maxp)
midp (polar minp(angle minp maxp) (/(distance minp maxp)2))
)
(setq minp(mapcar '(lambda(x y)(+ x y))TMX minp));;转换(WCS)
(setq mAXp(mapcar '(lambda(x y)(+ x y))TMX mAXp))
(setq midp (mapcar '(lambda(x y)(+ x y))TMX midp));;转换(WCS)
(setq txtang(+ kuaiang (cdr (assoc 50 (entget entBlkName)))));;;块的旋转角度+块内文字旋转角度
(setq FINDLST (cons (list "B" oldobj etext midp minp MAXP txtang) FINDLST))
(grtext -2 (strcat "正在搜索块内文字,请耐心等候" (nth biaojinum biaoji)))
(if (< biaojinum 8)(setq biaojinum (1+ biaojinum))(setq biaojinum 0))
(setq js2(1+ js2))
)
)
)
)
)
(setq xBlkDef entName1)
)
(SETQ oldinserp (cdr (assoc 10 (entget oldkent))))
)
;;;***************************************************
;;;获取各类型文字选择集
;;;***************************************************
(defun getss(/ strtype sslst blklst attlst)
(if(= wqpp "1")(setq ppzfc oldch)(setq ppzfc (strcat "*" oldch "*")))
(setq vartxtlst (list "ssINSERT" "sstext" "ssmtext" "ssTCH_*TEXT" "ssTCH_DRAWINGNAME")
filterlst (list "INSERT" "TEXT" "MTEXT" "TCH_*TEXT" "TCH_DRAWINGNAME")
)
(if ss;;;如果没有选择到，则所有选择集复位
(ssgflt ss vartxtlst filterlst)
(setq ssINSERT nil sstext nil ssmtext nil ssTCH_*TEXT nil ssTCH_DRAWINGNAME nil)
)
;;;1、普通文字查找
(IF (= dhwz "0")(SETQ sstext NIL))
(IF (= dUOhwz "0")(SETQ ssMtext NIL))
(IF (= tzwz "0") (SETQ ssTCH_*TEXT NIL))
(IF (= tzqt "0") (SETQ ssTCH_DRAWINGNAME NIL))
(setq sslst (vl-remove nil(list sstext ssmtext ssTCH_*TEXT ssTCH_DRAWINGNAME)))
(repeat (setq h (length sslst))
(command "select"
(if sstxt
sstxt
(setq sstxt (ssadd))
)
(nth (setq h (1- h)) sslst)
""
)
(setq sstxt
(ssget "p"
(list (cons 0 "TEXT,MTEXT,TCH_*TEXT,TCH_DRAWINGNAME"))
)
);;;若不过滤，则文字和线等成组时会连线一起选，出错
(if sstxt
(progn
(setq js3 0
newsstxt (ssadd)
)
(repeat (setq ct0 (sslength sstxt))
(setq ob (vlax-ename->vla-object
(setq en1 (ssname sstxt (setq ct0 (1- ct0))))
)
edata (entget en1)
txtang (cdr (assoc 50 edata))
etext (cdr (assoc 1 edata))
entype (cdr (assoc 0 edata))
)
(if (or (wcmatch (if (= qfdxx "0")
(strcase etext)
etext
)
(if (= qfdxx "0")
(strcase ppzfc)
ppzfc
)
)
(wcmatch (if (= qfdxx "0")
(strcase etext)
etext
)
(if (= qfdxx "0")
(strcase oldch)
oldch
)
)
(= (if (= qfdxx "0")
(strcase etext)
etext
)
(if (= qfdxx "0")
(strcase ppzfc)
ppzfc
)
)
(= (if (= qfdxx "0")
(strcase etext)
etext
)
(if (= qfdxx "0")
(strcase oldch)
oldch
)
)
)
(progn
(setq findlst (cons (list "C" ob etext txtang) findlst))
(setq js3 (1+ js3))
)
)
)
)
)
)
;;;3、块内文字匹配查找
(if (= knwz "1")
(progn
(if ssINSERT
(COMMAND "SELECT" ssINSERT "")
)
(setq ssknwz (ssget "P" (list (cons 0 "INSERT")(cons 66 0)))
JS2 0
)
(if ssknwz
(progn
(setq stime(getvar"date"))
(setq biaoji '("|" "||" "|||" "|||||" "||||||" "|||||||" "||||||||" "|||||||||" "||||||||||" ) biaojinum 0)
(grtext -2 (strcat "正在搜索块内文字,请耐心等候" (nth biaojinum biaoji)))
(repeat (SETQ N (sslength ssknwz))
(setq oldkent (SSNAME ssknwz (SETQ N (1- N))))(vlax-ename->vla-object oldkent)
(SETQ oldinserp (cdr (assoc 10 (entget oldkent))))
(ayGetAllEntInBLK oldkent)
)
(setq etime(getvar"date"))
(grtext -2 (strcat"搜索块内文字完成，耗时"(rtos(* 86400.0 (- (- etime stime) (fix (- etime stime))))2 2)"秒..."))
)
)
)
)
;;;2、属性文字匹配查找
(if (= sxwz "1")
(progn
(if ssINSERT
(COMMAND "SELECT" ssINSERT "")
)
(setq sssxwz (ssget "P" (list (cons 0 "INSERT") (cons 66 1)))
JS1 0
)
(if sssxwz
(repeat (setq n (sslength sssxwz))
(if (setq vlae (vlax-ename->vla-object
(ssname sssxwz (setq n (1- n)))
)
)
(progn
(setq attlst
(vlax-safearray->list
(vlax-variant-value (vla-GETATTRIBUTES vlae))
)
)
(repeat (setq m (length attlst))
(setq etext
(vlax-get-property
(setq attobj (nth (setq m (1- m)) attlst))
'textstring
)
)
(setq txtang(vla-get-rotation attobj))
(if (wcmatch (if (= qfdxx "0")
(strcase etext)
etext
)
(if (= qfdxx "0")
(strcase ppzfc)
ppzfc
)
)
(PROGN
(setq findlst
(cons (list "A" attobj etext txtang) findlst)
)
(SETQ JS1 (1+ JS1))
)
)
)
)
)
)
)
)
)
(if findlst (setq findlst (vl-sort findlst '(lambda(x y)(<(caddr x)(caddr y))))))
(if findlst (progn (setq j 0)(setq findlst(mapcar '(lambda(x)(setq j(1+ j))(append (list(car x)(cadr x)(strcat "["(itoa j)"] "(caddr x)))(cdddr x)))findlst))))
(zhuangtai)
)
;;;****************************************************
;;;将各类型文字列表分类
;;;****************************************************
(defun divss(lst)
(if lst
(foreach x lst
(COND((SETQ GTXT(assoc "C"(list x)))
(setq PUTONGTEXT (CONS (CdR GTXT) PUTONGTEXT))
)
((SETQ GTXT(assoc "B" (list x)))
(setq KUAITEXT (CONS (CDR GTXT) KUAITEXT))
)
((SETQ GTXT(assoc "A" (list x)))
(setq SHUXINGTEXT (CONS (CdR GTXT) SHUXINGTEXT))
)
)
)
)
(setq PUTONGTEXT(reverse PUTONGTEXT)KUAITEXT(reverse KUAITEXT)SHUXINGTEXT(reverse SHUXINGTEXT))
)
;;;****************************************************
;;;替换子程序
;;;*****************************************************
(defun tihuan (lst)
(divss lst)
(SETQ JS1 (LENGTH putongtext) JS2 (LENGTH shuxingtext) JS3 (LENGTH kuaitext))
(if putongtext
(repeat (setq n
(cond
((= re 3)
(length PUTONGTEXT)
)
((= replace "1")
1
)
)
)
(cond ((= re 3)
(setq pte (nth (setq n(1- n)) PUTONGTEXT))
(setq ob (car pte)
textqz(strcat "[" (ITOA(1+(vl-position (cons "C" pte) findlst)))"] ")
etext(VLA-GET-TEXTSTRING OB)
txtang(last pte)
)
(GETBOX ob)
(setq elle(entlast))
(if (/= txtang 0.0) (vla-rotate (VLAX-ENAME->VLA-OBJECT elle)(vlax-3d-point midp)txtang))
)
((= replace "1")
(setq ob (car(setq pte(cdr(setq e(nth (atoi drcznr) findlst))))))
(if ob
(progn
(setq textqz(strcat "[" (ITOA(1+(vl-position (cons "C" pte) findlst)))"] ")
etext (VLA-GET-TEXTSTRING OB)
)
(zoome e)
)
)
)
)
(if ob
(progn
(setq entype (cdr(assoc 0(entget(vlax-vla-object->ename ob)))))
(setq newtext(getnewtext etext))
(cond((AND(= entype "TEXT")(= dhwz "1"))
(vlax-put-property ob 'TextString newtext)
)
((AND(= entype "TCH_MTEXT")(= tzwz "1"))
(entmod (subst (cons 1 newtext) (assoc 1 edata) edata))
)
((AND(= entype "MTEXT")(= duohwz "1"))
(vlax-put-property ob 'TextString newtext)
)
((AND(= entype "TCH_TEXT")(= tzwz "1"))
(vlax-put-property ob 'Text newtext)
)
((AND(= entype "TCH_DRAWINGNAME")(= tzqt "1"))
(vlax-put-property ob 'NameText newtext)
)
)
(vla-update ob )
(setq findlst (subst (list "C" ob (strcat textqz newtext) txtang)(list "C" ob (cadr pte) txtang)findlst))
(adlst "9" (mapcar 'caDdr findlst))
(setq wxtsstr (strcat (itoa(1+(atoi drcznr))) "\/" (itoa (length findlst))" 当前为普通文本:" etext "改为" newtext))
(set_tile "wxts" wxtsstr)
)
)
)
)
(if shuxingtext
(MAPCAR '(LAMBDA (x)
(if (assoc(CaR x)shuxingtext)
(progn
(setq etext (vla-get-textstring (car x))
textqz(strcat "[" (ITOA(1+(vl-position (cons "A" x) findlst)))"] ")
)
(setq txtang (last x))
(vla-put-textstring (car x) (setq newtext(getnewtext etext)))
(vla-update (car x))
(getbox (car x))
(if (/= txtang 0.0) (vla-rotate (VLAX-ENAME->VLA-OBJECT (entlast))(vlax-3d-point midp)txtang))
(if (/= re 3)
(vla-zoomwindow myacad (vlax-3d-point(MAPCAR '(LAMBDA(X Y)(- X Y))minp (list(* (distof jiaoju) 100) (* (distof jiaoju) 100))))
(vlax-3d-point(MAPCAR '(LAMBDA(X Y)(+ X Y))maxp (list(* (distof jiaoju) 100) (* (distof jiaoju) 100)))))
)
(setq findlst (subst (list "A" (car x) (strcat textqz newtext) (last x))(list "A" (car x) (cadr x) (last x))findlst))
(adlst "9" (mapcar 'caDdr findlst))
(setq wxtsstr (strcat (itoa(1+(atoi drcznr))) "\/" (itoa (length findlst))" 当前为块属性文本:" etext"改为"newtext))
(set_tile "wxts" wxtsstr)
)
)
)
(cond ((= re 3)
shuxingtext
)
((= replace "1")
(list(cdr(nth (atoi drcznr) findlst)))
)
)
)
)
(if kuaitext
(progn
(repeat (setq knum(length kuaitext))
(if (not(member (setq blkname(vla-get-name(car(nth (setq knum(1- knum))kuaitext))))blklst))
(setq blklst(cons blkname blklst))
)
)
(vlax-for blk (vla-get-blocks(setq mydoc(vla-get-activedocument(vlax-get-acad-object))))
(if (member (setq blkname(vla-get-name blk))blklst)
(progn
(SETQ NN 0)
(repeat (vla-get-count blk)
(if(and(or(= "AcDbText" (vla-get-objectname (setq oldobj(vla-item blk NN))))
(= "AcDbMText" (vla-get-objectname (setq oldobj(vla-item blk NN))))
)
(setq etext(vla-get-textstring oldobj))
(wcmatch (if (= qfdxx "0") (strcase etext )etext)(if (= qfdxx "0")(strcase ppzfc )ppzfc))
)
(progn
(if (or (= re 3)(and(= replace "1")(=(car(nth (atoi drcznr)findlst))"B")(= blkname (vla-get-name(cadr(nth (atoi drcznr)findlst))))))
(progn
(setq thknum 0)
(vla-put-textstring oldobj (setq newtext(getnewtext etext)))
(vla-update oldobj)
(SETQ BLKSS(ssget "X"(list (cons 0 "insert")(cons 2 blkname))))
(if BLKSS
(progn
(setq thknum(sslength BLKSS) MM 0)
(REPEAT thknum
(vla-update (SETQ OB(VLAX-ENAME->VLA-OBJECT(SSNAME BLKSS MM))))
(GETBOX OB)
(SETQ MM(1+ MM))
)
)
)
(MAPCAR '(LAMBDA(x)
(if (and (= (car x) "B")(= (vla-get-name (cadr x)) blkname))
(progn
(SETQ textqz(strcat "[" (ITOA(1+(vl-position x findlst)))"] "))
(setq findlst(subst (list "B" (NTH 1 x) (strcat textqz newtext) (NTH 3 x)(NTH 4 x)(NTH 5 x)) x findlst))
(setq thknum (1+ thknum))
)
)
)
findlst
)
(adlst "9" (mapcar 'caDdr findlst))
(setq wxtsstr (strcat "块名:" blkname "文本"etext"改为"newtext"..." "共更新块参照" (itoa thknum)"个"))
(set_tile "wxts" wxtsstr)
)
)
)
)
(setq nn(1+ nn))
)
)
)
)
)
)
(cond
((=(type drcznr) 'str)
(if (= up "1")(setq drcznr(itoa(1-(atoi drcznr))))(setq drcznr(itoa(1+(atoi drcznr)))))
)
((=(type drcznr) 'int)
(if (= up "1")(setq drcznr(itoa(1- drcznr)))(setq drcznr(itoa(1+ drcznr))))
)
)
(setq endnum(length findlst))
(cond
((and(<(atoi drcznr)0)(= up "1"))
(setq drcznr (itoa (1- endnum)))
)
((and(>=(atoi drcznr)endnum)(= down "1"))
(setq drcznr "0")
)
)
(set_tile "9" drcznr)
(if (/= replace "1")(jieguotishi))
(setq putongtext nil shuxingtext nil kuaitext nil)
);_ END tihuan
;;;********************************************************
;;;;;;全部亮显:普通文字亮显，块参照文字画椭圆亮显
;;;********************************************************
(DEFUN LIANGXIAN( lst / )
(SETQ PTLSS(SSADD) SXLSS(SSADD)kLSS(SSADD))
(IF (= RE 4)
(PROGN
(divss lst)
(IF PUTONGTEXT
(PROGN
(MAPCAR '(LAMBDA(X)(SSADD (VLAX-VLA-OBJECT->ENAME X) PTLSS))(MAPCAR 'CAR PUTONGTEXT))
)
)
(IF SHUXINGTEXT
(PROGN
(MAPCAR '(LAMBDA(X)(SSADD (VLAX-VLA-OBJECT->ENAME X) SXLSS))(MAPCAR 'CAR SHUXINGTEXT))
)
)
(IF KUAITEXT
(progn
(MAPCAR '(LAMBDA(X)
(SETQ TXT (nth 1 x)
midp(nth 2 x)
inserp(nth 3 x)
txtang(nth 4 x)
)
(EMAKEEL midp inserp tcol txt)
(if (/= txtang 0.0) (vla-rotate (VLAX-ENAME->VLA-OBJECT (entlast))(vlax-3d-point midp)txtang))
)
KUAITEXT
)
(setq elliss(ssget "x" (list(cons 0 "ellipse")(cons 8 "findttz"))))
)
)
(cond
((and PTLSS SXLSS elliSS)(command "select" PTLSS SXLSS elliSS "")(sssetfirst nil (ssget"p")))
( PTLSS (sssetfirst nil PTLSS))
( SXLSS(sssetfirst nil SXLSS))
( elliSS(sssetfirst nil elliSS))
)
)
)
(if (/= replace "1")(jieguotishi))
(setq putongtext nil shuxingtext nil kuaitext nil)
)
;;;**************************************************
;;;;;;查找替换结果提示
;;;**************************************************
(defun jieguotishi()
(COND
((= RE 3)
(if (>(+ (if (and(= sxwz "1")js1) js1 0) (if (and(= knwz "1")js2) js2 0)(if (and (or (= dhwz "1")(= duohwz "1")(= tzwz "1")(= tzqt "1"))js3) js3 0))0)
(progn
(setq wxtsstr (strcat "共替换了" (itoa (+ (if js1 js1 0) (if js2 js2 0)(if js3 js3 0)))"个文本..."
(if (and (or (= dhwz "1")(= duohwz "1")(= tzwz "1")(= tzqt "1"))js3(> js3 0)) (strcat"普通文本:" (itoa js3) "个...")"")
(if (and(= sxwz "1")js1(> js1 0)) (strcat "属性文本:" (itoa js1) "个...")"")
(if (and(= knwz "1")js2(> js2 0)) (strcat "块参照文本:" (itoa js2) "个...")"")
)
)
(set_tile "wxts" wxtsstr)
(princ (strcat "\n"wxtsstr))
)
(progn
(IF FINDLST
(setq wxtsstr(strcat "共替换了" (itoa (LENGTH FINDLST)) " 个文本..."))
(if (AND(NOT FINDLST)(= (+ (if js1 js1 0) (if js2 js2 0) (if js3 js3 0)) 0))(setq wxtsstr(strcat "未找到符合要求的包含 " oldch " 的文本...")))
)
(set_tile "wxts" wxtsstr)
(princ (strcat "\n"wxtsstr))
)
)
)
((or(= RE 4)(= RE 8))
(if (>(+ (if (and(= sxwz "1")js1) js1 0) (if (and(= knwz "1")js2) js2 0)(if (and (or (= dhwz "1")(= duohwz "1")(= tzwz "1")(= tzqt "1"))js3) js3 0))0)
(progn
(setq wxtsstr (strcat "共找到了" (itoa (+ (if js1 js1 0) (if js2 js2 0)(if js3 js3 0)))"个文本..."
(if (and (or (= dhwz "1")(= duohwz "1")(= tzwz "1")(= tzqt "1"))js3(> js3 0)) (strcat"普通文本:" (itoa js3) "个...")"")
(if (and(= sxwz "1")js1(> js1 0)) (strcat "属性文本:" (itoa js1) "个...")"")
(if (and(= knwz "1")js2(> js2 0)) (strcat "块参照文本:" (itoa js2) "个...")"")
)
)
(set_tile "wxts" wxtsstr)
(princ (strcat "\n"wxtsstr))
)
(progn
(IF FINDLST
(setq wxtsstr(strcat "共找到了" (itoa (LENGTH FINDLST)) " 个文本..."))
(if (AND(NOT FINDLST)(= (+ (if js1 js1 0) (if js2 js2 0) (if js3 js3 0)) 0))(setq wxtsstr(strcat "未找到符合要求的包含 " oldch " 的文本...")))
)
(set_tile "wxts" wxtsstr)
(princ (strcat "\n"wxtsstr))
)
)
)
((= RE 7)
(IF FINDLST
(setq wxtsstr(strcat "共找到了" (itoa (LENGTH FINDLST)) " 个文本..."))
(if (AND(NOT FINDLST)(= (+ (if js1 js1 0) (if js2 js2 0) (if js3 js3 0)) 0))(setq wxtsstr(strcat "未找到符合要求的包含 " oldch " 的文本...")))
)
(set_tile "wxts" wxtsstr)
(princ (strcat "\n"wxtsstr))
)
)
)
;;;******************************************
;;;帮助信息
;;;******************************************
(defun helpmsg()
(ALERT "文本查找替换 BY YJR111 2012-10-10
\n 1、可支持通配符；
\n 2、双击查找结果中的文字可以zoom该文字；
\n 3、单击定位查找结果中的文字，可以在替换栏内自由输入替换内容进行替换；
\n 4、上一个和下一个可以不停进行定位搜索；
\n 5、查找结果中定位一个文字后，若替换内容相同，可不停按替换按钮进行相同替换；
\n 6、定位时画椭圆做标记，自动删除；
\n 7、块文字在全部亮显时是亮显椭圆标记，可以用删圆命令删除；
\n 8、单个替换后结果框内实时显示替换结果，并可双击查看；
\n 9、圆的颜色可以更改；
\n 10、焦距可调节文字缩放效果，数值=0为最大放大居中；
\n 11、除非必要，选项中块文字最好不选，否则影响速度；
\n 12、块内文字圆标识，其他文字（包括属性）椭圆标识;
\n 13、其他请自行测试，如有bug，请QQ告知：16570954."
)
)
;;;*************************************************
;支持cad单行和多行文字、TZ单行和多行文字
;查找的文字串可以使用*、？、#等特殊符号，但如果文本中本就存在此特殊符号时可能出错，主要wcmatch函数匹配特殊符号
(defun c:WFF()(c:findttz)(princ))
(vl-load-com)
(defun c:findttz (/ fn x dclid lin return# sstxt
ssl ct0 ct edata etext txtln subln schct ss
DCL_ID newtext en1 ob entype a OLDSSTXT oldss
wqpp dhwz duohwz sxwz tzwz tzqt lightss js1 js2 vartxtlst filterlst
ppzfc newsstxt re entNameList PUTONGTEXT kuaitext shuxingtext
wxtsstr ssINSERT sstext ssmtext ssTCH_*TEXT ssTCH_DRAWINGNAME
onerow replace JS1 JS2 JS3 jiaoju elliss screenpt n nn mm m j k e
etext pte rv1
)
;;;****************************************************************************
;;;出错处理
;;;****************************************************************************
(defun *error* (msg)
(if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
(princ "\n程序退出...")
(princ (strcat "\n" msg))
)
(SETQ FINDLST NIL SS NIL )
(princ)
)
;;;****************************************************************************
;;;初始化条件
;;;****************************************************************************
(setvar "cmdecho" 0)
(vla-startUndoMark (setq mydoc(vla-get-activedocument(setq myacad(vlax-get-acad-object)))))
(if(not(tblsearch "layer" "findttz"))
(vla-add (vla-get-layers mydoc) "findttz")
)
(if (= qk "1")(setq findlst nil))
(xsdhk)
(vla-endUndoMark mydoc)
(setvar 'nomutt 0)
(setvar "cmdecho" 1)
(princ)
) ;_ END defun
(princ)
(defun prin()
(princ "\n*************显示所有命令快捷键:FFF*************** ")
(princ)
)
(prin)
;; Silent load.
(princ)
AutoCAD和浩辰CAD，gCAD都可以用的lisp
猜你喜欢
转载自blog.csdn.net/VB973490770/article/details/50444599
今日推荐
周排行