;;-------------------------------------------------------------------------------
;000fff
;日期：2016-09-05-201711-21
;簡介：AutoCAD和浩辰GCAD都能用的lisp小程序。
;文件名：mylisp20160113.lsp。
;可以替換該文件內容：C:\Gstarsoft\浩辰CAD電氣2013\GRX8\OtherApp.lsp
;或者替換autocad中的C:\Program Files\AutoCAD 2005\Support\acad2005doc.lsp
;注：
;1.所有快捷指令都是爲了適應左手鼠標右手鍵盤的操作。
;2.如果你是右手鼠標左手鍵盤請自己把快捷指令更改到自己操作方便的按鍵上。
;3.命令行輸入AAA回車，命令行會列出所有快捷指令的含義。
;-指令列表A~Z
;AAAAAAAAAA
;--------------------
;AAA來進行指令提示。
(defun c:AAA()
(princ "快捷指令：
AAA：進行指令提示；
bcc：文件保存操作另存爲新的文件,文件名後綴當前時間。
bccc：bcc功能增加關閉文件指令。
K：編輯單行文字。
KK：取消對象選擇。
KH：合併單行文字。
KRQ：文字改爲當前日期。
KTT：插入日期。
KN：用選中單行文字的內容去替換其他單行文字的內容-挨個替換。
LL：對選中線段圓弧多段線合併成一根多段線。
LLL：對首尾相接的線段曲線合併成多段線。
LJK：量取直線、多段線、樣條曲線、圓弧、圓、橢圓的長度。
LLJK：統計選擇線段的總長度。
LM：標註線段長度。
LLK：把選中的對象用多段線連接起來-連連看。
GC：將選中對象移入當前圖層。
WFF：非常高級查找文字功能，只能找autocad文字，天正，浩辰等插件文字無法查找到。
企鵝：973490770")
(princ "\n*************顯示所有命令快捷鍵:AAA***************")
(princ)
)
;BBBBBBBBBB
;--------------------
;001、文件保存操作另存爲新的文件（指令：bcc）或者保存後自動關閉該dwg文檔（指令：bccc），省的每次退出還要保存之後，按關閉按鈕。
;==============================
;軟件作者：百度用戶：greatlmy、黑光計劃
;==============================
;注意：另存爲新的CAD文件快捷鍵“bcc”
;1.每次保存的文件名都會後綴一個時間字符串例如：
;“數據表-201607281430.dwg”----表示2016年7月28號下午14點30分保存的文件。
;本程序要求CAD文件名的格式爲【“文件名”+“-000000000000”.dwg】，第一次保存後，12個“0”會變成當前時間例如：“201701131212”精確到分鐘。
;2.如果一分鐘內執行多次保存操作，會替換同名文件而不產生新文件。
;3.該軟件用來生成一系列的不同時間的歷史文件，
;4.如果計算機死機，你就可以根據後綴時間找到最近編輯的CAD文件。
;5.（然而CAD自己有定時保存功能，CAD會定時自動保存到這個目錄下（【開始】【運行】%temp%）），我個人感覺CAD的自動保存功能不靠譜，很多時候找不到最後的那份文件。
;6.所以我編寫手動保存程序，快捷指令bcc，幫我們每完成一次重要的CAD圖紙更改都存檔一份新的文件，並在文件名中後綴當前時間。
;7.下邊是程序段。
;=====================================================
(defun c:Bcc (/ sj fn n)
(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)
)
;保存+另存+關閉三合一保存完畢自動後關閉該dwg文檔。
(defun c:Bccc (/ sj fn n)
(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)
)
;======我是華麗分割線======================
;C
;D
;E
;F
;GGGGGGGGGG
;001、將選中對象移入當前圖層。【浩辰電氣2013】
(defun c:GC(/ ss)
(setq ss (ssget))
(command "LAYCUR" ss "")
)
;H
;I
;J
;KKKKKKKKKK
;文字操作
;001、單行文字對象編輯【浩辰電氣2013】
(defun C:K(/ ss)
(princ "\n文字編輯")
(prompt "編輯浩辰電氣文字")
(setq ss (ssget))
(command "IcEditEnt" ss )
)
;----------
;002、取消對象選擇
(defun c:KK()
(prompt "取消對象選擇")
(command )
)
;003、合併成單行文字【浩辰電氣2013】
(defun c:KH(/ SS)
(setq ss (ssget))
(command "IcTextMerge" ss "" "D")
)
;004、將文字改爲日期【浩辰電氣2013】
(defun c:Krq(/ 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))
;005、插入日期和時間【浩辰電氣2013】
(defun C:Ktt(/ 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)
)
;006、用選中單行文字的內容去替換其他單行文字的內容-挨個替換【浩辰電氣2013】
;作者qq：1434177703
(defun c:KN(/ s1 s2)
(vl-load-com)
(while (setq s2 (car (entsel "\n點取替換源文字:")))
(if s2
(while (setq s1 (car (entsel "\n點取被替換文字:")))
(Vlax-Put-Property (Vlax-Ename->Vla-Object s1) 'Content (Vlax-Get (Vlax-Ename->Vla-Object s2) 'Content ))
))))
;LLLLLLLLLL
;--------------------
;線條操作
;001、選中的直曲線連接成一條多段線。
(defun c:LL(/ ss)
(prompt "合併多條多段線")
(setq ss (ssget))
(setvar "peditaccept" 1)
(command "pedit" "M" ss "" "j" "" "")
(setvar "peditaccept" 0)
(princ)
)
;002、所有首尾相連的直曲線創建成一條多段線
(defun c:LLL()
(setvar "peditaccept" 1)
(setq ss (ssget))
(command "pedit" ss "j" "all" "" "")
(setvar "peditaccept" 0)
(princ)
)
;003、量取直線、多段線、樣條曲線、圓弧、圓、橢圓的長度。
(defun c:Ljk()
(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)
)
;004、統計選擇線段的總長度。
(defun C:LLjk (/ 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) " .")))
;--------------------
;005.標註線段長度
(defun c:LM()
(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)
)
;006.把選中的對象用多段線連接起來-連連看
;作者qq：1434177703
(defun c:LLk ( / e i msg odlst pts ss x)
(vl-load-com)
(setq *ACAD* (vlax-get-acad-object)
*DOC* (vla-get-ActiveDocument *ACAD*)
)
(defun *error*(msg)
(mapcar 'setvar '("cmdecho" "osmode") odlst)
(vlax-invoke-method *DOC* 'EndUndoMark)
(princ msg)
)
(vlax-invoke-method *DOC* 'StartUndoMark)
(setq odlst (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 0))
(setq ss (ssget '((0 . "TEXT"))))
(setq pts nil)
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq pts (cons (cdr (assoc 10 (entget e))) pts))
)
(entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length pts)))
(mapcar '(lambda (x) (cons 10 x)) pts)))
(mapcar 'setvar '("cmdecho" "osmode") odlst)
(vlax-invoke-method *DOC* 'EndUndoMark)
)
;M
;N
;O
;P
;Q
;R
;S
;TTTTTTTTTT
;U
;V
;WWWWWWWWWW
;X
;Y
;Z
;======我是華麗分割線======================
; 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)
)
(defun OtherAppLoad (/)
(princ)
)
;;-------------------------------------------------------------------------------
;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
;注：
;1.所有快捷指令都是爲了適應左手鼠標右手鍵盤的操作。
;2.如果你是右手鼠標左手鍵盤請自己把快捷指令更改到自己操作方便的按鍵上。
;3.命令行輸入AAA回車，命令行會列出所有快捷指令的含義。
;;*****************************************************************************
;;首先非常非常感謝原創作者：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
;; Silent load.
(princ "快捷指令：
AAA：進行指令提示；
bcc：文件保存操作另存爲新的文件,文件名後綴當前時間。
bccc：bcc功能增加關閉文件指令。
K：編輯單行文字。
KK：取消對象選擇。
KH：合併單行文字。
KRQ：文字改爲當前日期。
KTT：插入日期。
KN：用選中單行文字的內容去替換其他單行文字的內容-挨個替換。
LL：對選中線段圓弧多段線合併成一根多段線。
LLL：對首尾相接的線段曲線合併成多段線。
LJK：量取直線、多段線、樣條曲線、圓弧、圓、橢圓的長度。
LLJK：統計選擇線段的總長度。
LM：標註線段長度。
LLK：把選中的對象用多段線連接起來-連連看。
GC：將選中對象移入當前圖層。
WFF：非常高級查找文字功能，只能找autocad文字，天正，浩辰等插件文字無法查找到。
企鵝：973490770")
(princ "*************顯示所有命令快捷鍵:AAA***************")
(princ)
mylisp_gcad20170121.lsp
發表評論
所有評論
還沒有人評論，想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.