| Autore |
 Discussione  |
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
 Inserito il - 30 aprile 2010 : 11:47:16
|
numinc
Scarica allegato:
 NumInc.zip
9,63 KB
|
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
Inserito il - 15 settembre 2010 : 12:54:06
|
http://sourceforge.net/projects/caddons/files/
;;; -------------------------------------------------------------------------------------
;;; AutoIncr.lsp v0.1
;;; Copyright© 2010-07-10
;;; Irné Barnard
;;; Contact: irne.barnard@gmail.com
;;;
;;;
;;; -------------------------------------------------------------------------------------
;;; *
;;; -------------------------------------------------------------------------------------
;;; This file is part of Caddons.
;;;
;;; Caddons is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public * as published by
;;; the Free Software Foundation, either version 3 of the *, or
;;; (at your option) any later version.
;;;
;;; Caddons is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public * for more details.
;;;
;;; You should have received a copy of the GNU General Public *
;;; along with Caddons. If not, see <http://www.gnu.org/*s/>.
;;;
;;;
;;; -------------------------------------------------------------------------------------
;;; Disclaimer
;;; -------------------------------------------------------------------------------------
;;; The following program(s) are provided "as is" and with all faults.
;;; Irné Barnard DOES NOT warrant that the operation of the program(s)
;;; will be uninterrupted and/or error free.
;;;
;;;
;;; -------------------------------------------------------------------------------------
;;; Summary of routines contained in this file
;;; -------------------------------------------------------------------------------------
;;; Increments text by placing / picking / selecting text / mtext / attributes
;;;
;;; Revision History:
;;; 0.1 First release
;;; 0.2 Fixed bug 3029986; Include Feature 3031153 + Add highlight after picking;
;;; Fixed bug 3031612; Added renumbering to feature 3031153; Fix bug 3032937
;;; underscores and spaces changed to hyphens for getkword compatibility; Added
;;; STop option to entity select / pick / create ...
;;;
;;; -------------------------------------------------------------------------------------
(vl-load-com)
;;; -------------------------------------------------------------------------------------
;;; Settings variables
;;; -------------------------------------------------------------------------------------
(setq AInc#Settings
'(1.0 ;Start value
1.0 ;Increment by
"INT" ;Type
"" ;Prefix
"" ;Suffix
0 ;Precision
1 ;Digits
)
AInc#Types
'(("INT" 0 nil)
("REAL" 0.0 nil)
("ALPHAU"
1
("A" "B" "C" "D" "E" "F" "G" "H" "J" "K" "L" "M" "N" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
)
)
("ALPHAL"
1
("a" "b" "c" "d" "e" "f" "g" "h" "j" "k" "l" "m" "n" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"
)
)
("ROMANU" 1.0 "MDCLXVI")
("ROMANL" 1.0 "mdclxvi")
("HEX" 0.0 "0123456789ABCDEF")
("BIN" 0.0 "01")
("OCT" 0.0 "01234567")
)
AInc#BlkAttrS
nil
AInc#Mode "Pick"
) ;_ end of setq
;;; -------------------------------------------------------------------------------------
;;; Converter function from integer to different base numeral
;;; -------------------------------------------------------------------------------------
;;; num = The number to be converted
;;; typ = List containing the type's settings
;;; Result: a string representing the converted number
;;; -------------------------------------------------------------------------------------
(defun AInc:Int2Base (num typ / neg str base)
(setq neg (< num 0)
num (fix (abs num))
base (strlen (last typ))
str ""
) ;_ end of setq
(while (> num 0)
(setq str (strcat (substr (last typ) (1+ (rem num base)) 1) str)
num (fix (/ num base))
) ;_ end of setq
) ;_ end of while
(if (eq str "")
(setq str "0")
) ;_ end of if
(if neg
(strcat "-" str)
str
) ;_ end of if
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Converter function from number to different base numeral
;;; -------------------------------------------------------------------------------------
;;; num = The number to be converted
;;; typ = List containing the type's settings
;;; prec = Precision for real number types
;;; Result: a string representing the converted number
;;; -------------------------------------------------------------------------------------
(defun AInc:Num2Base (num typ prec / neg i f str1 str2 str)
(setq neg (< num 0)
num (abs num)
prec (fix (abs prec))
i (fix num)
f (fix (* (- num i) (expt (strlen (last typ)) prec)))
) ;_ end of setq
(if (and (setq str1 (AInc:Int2Base i typ))
(setq str2 (AInc:Int2Base f typ))
) ;_ end of and
(progn
(if neg
(setq str "-")
(setq str "")
) ;_ end of if
(if (> prec 0)
(progn
(repeat (- prec (strlen str2))
(setq str2 (strcat "0" str2))
) ;_ end of repeat
(setq str (strcat str str1 "." str2))
) ;_ end of progn
(setq str (strcat str str1))
) ;_ end of if
) ;_ end of progn
) ;_ end of if
str
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Converter function from number to alphabetic
;;; -------------------------------------------------------------------------------------
;;; num = The number to be converted
;;; typ = List containing the type's settings
;;; Result: a string representing the converted number
;;; -------------------------------------------------------------------------------------
(defun AInc:Num2Alpha (num typ / str)
(setq str "")
(if (> (setq num (fix (abs num))) 0)
(progn
(while (>= num (length (last typ)))
(setq str (strcat (nth (rem num (length (last typ))) (last typ)) str)
num (fix (/ num (length (last typ))))
) ;_ end of setq
) ;_ end of while
(setq str (strcat (nth (1- (rem num (length (last typ)))) (last typ)) str))
) ;_ end of progn
) ;_ end of if
str
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Converter function from number to ROMANL numerals
;;; -------------------------------------------------------------------------------------
;;; num = The number to be converted
;;; typ = List containing the type's settings
;;; Result: a string representing the converted number
;;; -------------------------------------------------------------------------------------
(defun AInc:Num2Roman (num typ / n str)
(if (and (> (setq num (fix (abs num))) 0)
(< num 4000)
) ;_ end of and
(progn
(setq str ""
n 0
num (itoa num)
) ;_ end of setq
(while (<= (setq n (1+ n)) (strlen num))
(cond
;; Thousands
((= (- (strlen num) n) 3)
(repeat (atoi (substr num n 1)) (setq str (strcat str (substr (last typ) 1 1))))
)
;; Hundreds
((= (- (strlen num) n) 2)
(cond
((wcmatch (substr num n 1) "1") (setq str (strcat str (substr (last typ) 3 1))))
((= (substr num n 1) "2")
(repeat 2 (setq str (strcat str (substr (last typ) 3 1))))
)
((= (substr num n 1) "3")
(repeat 3 (setq str (strcat str (substr (last typ) 3 1))))
)
((= (substr num n 1) "4")
(setq str (strcat str (substr (last typ) 3 1))
str (strcat str (substr (last typ) 2 1))
) ;_ end of setq
)
((= (substr num n 1) "5") (setq str (strcat str (substr (last typ) 2 1))))
((= (substr num n 1) "6")
(setq str (strcat str (substr (last typ) 2 1))
str (strcat str (substr (last typ) 3 1))
) ;_ end of setq
)
((= (substr num n 1) "7")
(setq str (strcat str (substr (last typ) 2 1)))
(repeat 2 (setq str (strcat str (substr (last typ) 3 1))))
)
((= (substr num n 1) "8")
(setq str (strcat str (substr (last typ) 2 1)))
(repeat 3 (setq str (strcat str (substr (last typ) 3 1))))
)
((= (substr num n 1) "9")
(setq str (strcat str (substr (last typ) 3 1))
str (strcat str (substr (last typ) 1 1))
) ;_ end of setq
)
) ;_ end of cond
)
;; Tens
((= (- (strlen num) n) 1)
(cond
((wcmatch (substr num n 1) "1") (setq str (strcat str (substr (last typ) 5 1))))
((= (substr num n 1) "2")
(repeat 2 (setq str (strcat str (substr (last typ) 5 1))))
)
((= (substr num n 1) "3")
(repeat 3 (setq str (strcat str (substr (last typ) 5 1))))
)
((= (substr num n 1) "4")
(setq str (strcat str (substr (last typ) 5 1))
str (strcat str (substr (last typ) 4 1))
) ;_ end of setq
)
((= (substr num n 1) "5") (setq str (strcat str (substr (last typ) 4 1))))
((= (substr num n 1) "6")
(setq str (strcat str (substr (last typ) 4 1))
str (strcat str (substr (last typ) 5 1))
) ;_ end of setq
)
((= (substr num n 1) "7")
(setq str (strcat str (substr (last typ) 4 1)))
(repeat 2 (setq str (strcat str (substr (last typ) 5 1))))
)
((= (substr num n 1) "8")
(setq str (strcat str (substr (last typ) 4 1)))
(repeat 3 (setq str (strcat str (substr (last typ) 5 1))))
)
((= (substr num n 1) "9")
(setq str (strcat str (substr (last typ) 5 1))
str (strcat str (substr (last typ) 3 1))
) ;_ end of setq
)
) ;_ end of cond
)
;; Ones
((= (- (strlen num) n) 0)
(cond
((wcmatch (substr num n 1) "1") (setq str (strcat str (substr (last typ) 7 1))))
((= (substr num n 1) "2")
(repeat 2 (setq str (strcat str (substr (last typ) 7 1))))
)
((= (substr num n 1) "3")
(repeat 3 (setq str (strcat str (substr (last typ) 7 1))))
)
((= (substr num n 1) "4")
(setq str (strcat str (substr (last typ) 7 1))
str (strcat str (substr (last typ) 6 1))
) ;_ end of setq
)
((= (substr num n 1) "5") (setq str (strcat str (substr (last typ) 6 1))))
((= (substr num n 1) "6")
(setq str (strcat str (substr (last typ) 6 1))
str (strcat str (substr (last typ) 7 1))
) ;_ end of setq
)
((= (substr num n 1) "7")
(setq str (strcat str (substr (last typ) 6 1)))
(repeat 2 (setq str (strcat str (substr (last typ) 7 1))))
)
((= (substr num n 1) "8")
(setq str (strcat str (substr (last typ) 6 1)))
(repeat 3 (setq str (strcat str (substr (last typ) 7 1))))
)
((= (substr num n 1) "9")
(setq str (strcat str (substr (last typ) 7 1))
str (strcat str (substr (last typ) 5 1))
) ;_ end of setq
)
) ;_ end of cond
)
) ;_ end of cond
) ;_ end of while
) ;_ end of progn
(setq str "")
) ;_ end of if
str
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Converter function from number to required type
;;; -------------------------------------------------------------------------------------
;;; num = The number to be converted
;;; typ = Type code to convert to
;;; dgt = Integer portion digits
;;; prec = Precision for real number types
;;; Result: a string representing the converted number
;;; -------------------------------------------------------------------------------------
(defun AInc:Num2Type (num typ dgt prec / str n neg)
(if (setq typ (assoc typ AInc#Types))
(if (= (cadr typ) 0)
(if (= (type (cadr typ)) 'INT)
(setq str (itoa (fix num)))
(if (= (type (last typ)) 'STR)
(setq str (AInc:Num2Base num typ prec))
(if (and (setq str (rtos num 2 prec)) (> prec 0) (not (wcmatch str "*`.*")))
(progn
(setq str (strcat str "."))
(repeat prec (setq str (strcat str "0")))
) ;_ end of progn
) ;_ end of if
) ;_ end of if
) ;_ end of if
(if (= (type (cadr typ)) 'INT)
(setq str (AInc:Num2Alpha num typ))
(setq str (AInc:Num2Roman num typ))
) ;_ end of if
) ;_ end of if
) ;_ end of if
(setq neg (wcmatch str "-*")
str (vl-string-trim " -" str)
)
(cond
((wcmatch (car typ) "ALPHA*,ROMAN*")
(repeat (- dgt (strlen str)) (setq str (strcat "_" str)))
)
((wcmatch str "*`.*")
(repeat (- dgt (vl-string-search "." str)) (setq str (strcat "0" str)))
)
(t
(repeat (- dgt (strlen str)) (setq str (strcat "0" str)))
)
)
(if neg
(setq str (strcat "-" str))
)
str
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Function to replace an item at index of a list
;;; -------------------------------------------------------------------------------------
;;; lst = The original list
;;; idx = Index of the item to replace
;;; val = Value of the new item
;;; Result: A new list with the item replaced
;;; -------------------------------------------------------------------------------------
(defun AInc:ListReplace (lst idx val / n ret)
(setq n (length lst))
(while (>= (setq n (1- n)) 0)
(if (= idx n)
(setq ret (cons val ret))
(setq ret (cons (nth n lst) ret))
) ;_ end of if
) ;_ end of while
ret
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Change settings through command line
;;; -------------------------------------------------------------------------------------
;;; settings = List containing the settings to be displayed
;;; Result: nil if Canceled, else a list containing the modified settings.
;;; -------------------------------------------------------------------------------------
(defun AInc:SettingsCmd (settings / AInc:SetShow ans temp str1 str2 $min $max AInc:SetChk fn f)
(defun AInc:SetShow (/ n)
(princ "\nE.g.: ")
(setq n (nth 0 settings))
(repeat 10
(princ (nth 3 settings))
(princ (AInc:Num2Type n (nth 2 settings) (nth 6 settings) (nth 5 settings)))
(princ (nth 4 settings))
(princ ", ")
(setq n (+ n (nth 1 settings)))
)
(princ "...\nType: ")
(princ (nth 2 settings))
(princ "; Start: ")
(princ (nth 0 settings))
(princ "; Vector: ")
(princ (nth 1 settings))
(princ "; Digits: ")
(princ (nth 6 settings))
(princ "; Precision: ")
(princ (nth 5 settings))
(princ "; Prefix: \"")
(princ (nth 3 settings))
(princ "\" ; Suffix: \"")
(princ (nth 4 settings))
(princ "\"")
(princ)
)
(defun AInc:SetChk (ans /)
(cond
((wcmatch ans "ALPHA*")
(setq $min 1
$max nil
)
(if (< (nth 0 settings) $min)
(setq settings (AInc:ListReplace settings 0 (float $min)))
)
)
((wcmatch ans "ROMANU*")
(setq $min 1
$max 399
)
(if (< (nth 0 settings) $min)
(setq settings (AInc:ListReplace settings 0 (float $min)))
)
(if (> (nth 0 settings) $max)
(setq settings (AInc:ListReplace settings 0 (float $max)))
)
)
)
)
(while (and (not (eq ans "eXit"))
(progn
(AInc:SetShow)
(initget 128 "Type Start Vector Digits preCision Prefix suFfix sAVe Load eXit")
(setq ans (getkword "\nChoice [Type/Start/Vector/Digits/preCision/Prefix/suFfix/sAVe/Load/eXit] <eXit>: "))
)
)
(cond
((eq ans "Prefix")
(if (setq temp (getstring t (strcat "\NPrefix (~ for none) <" (nth 3 settings) ">: ")))
(if (eq temp "~")
(setq settings (AInc:ListReplace settings 3 ""))
(if (/= temp "")
(setq settings (AInc:ListReplace settings 3 temp))
)
)
)
)
((eq ans "suFfix")
(if (setq temp (getstring t (strcat "\NSuffix (~ for none) <" (nth 4 settings) ">: ")))
(if (eq temp "~")
(setq settings (AInc:ListReplace settings 4 ""))
(if (/= temp "")
(setq settings (AInc:ListReplace settings 4 temp))
)
)
)
)
((eq ans "Type")
(setq str1 ""
str2 ""
)
(foreach temp AInc#Types
(setq str1 (strcat str1 " " (car temp))
str2 (strcat str2 "/" (car temp))
)
)
(setq str1 (vl-string-trim "// \/t/n" str1)
str2 (vl-string-trim "// \/t/n" str2)
)
(initget 129 str1)
(if (setq ans (getkword (strcat "[" str2 "] <" (nth 2 settings) ">: ")))
(setq settings (AInc:ListReplace settings 2 ans))
)
(AInc:SetChk ans)
)
((eq ans "Start")
(if (setq temp (getreal (strcat "\nStart number <" (rtos (nth 0 settings)) ">: ")))
(setq settings (AInc:ListReplace settings 0 temp))
)
(AInc:SetChk ans)
)
((eq ans "Vector")
(if (setq temp (getreal (strcat "\NVector number <" (rtos (nth 1 settings)) ">: ")))
(setq settings (AInc:ListReplace settings 1 temp))
)
)
((eq ans "Digits")
(if (and (setq temp (getint (strcat "\NDigits <" (rtos (nth 6 settings)) ">: ")))
(> temp 0)
)
(setq settings (AInc:ListReplace settings 6 temp))
)
)
((eq ans "preCision")
(if (and (setq temp (getint (strcat "\NPrecision <" (rtos (nth 5 settings)) ">: ")))
(>= temp 0)
)
(setq settings (AInc:ListReplace settings 5 temp))
)
)
((eq ans "Load")
(if (or (and (or (= (getvar "FILEDIA") 0)
(> (logand (getvar "CMDACTIVE") (+ 4 16 32 64)) 0)
)
(setq fn (getstring t "File path: "))
(setq f (open fn "r"))
)
(and (setq fn (getfiled "Load Increment Settings" (getvar "DWGPREFIX") "inc" 12))
(setq f (open fn "r"))
)
)
(progn
(setq str1 "")
(while (setq str2 (read-line f)) (setq str1 (strcat str1 "\n" str2)))
(close f)
(setq settings (read str1))
(AInc:SetChk ans)
)
)
)
((eq ans "sAVe")
(if (or (and (or (= (getvar "FILEDIA") 0)
(> (logand (getvar "CMDACTIVE") (+ 4 16 32 64)) 0)
)
(setq f (open fn "w"))
)
(and (setq fn (getfiled "Save Increment Settings" (getvar "DWGPREFIX") "inc" 5))
(setq f (open fn "w"))
)
)
(progn
(prin1 settings f)
(close f)
)
)
)
)
)
settings
)
;;; Function to load AutoIncr dialog
(defun load_dialog_AutoIncr (/ fn f)
(setq fn (strcat (getvar "TEMPPREFIX") "AutoIncr.DCL"))
(setq f (open fn "w"))
(write-line
"// -------------------------------------------------------------------------------------"
f
)
(write-line "// AutoIncr.DCL v1.0" f)
(write-line "//" f)
(write-line "// Copyright© 2010-07-10" f)
(write-line "// Irné Barnard (irneb)" f)
(write-line "//" f)
(write-line "// Contact: irneb @ AUGI.com" f)
(write-line "//" f)
(write-line "// Permission to use, copy, modify, and distribute this software" f)
(write-line "// for any purpose and without fee is hereby granted, provided" f)
(write-line "// that the above copyright notice appears in all copies and" f)
(write-line "// that both that copyright notice and the limited warranty and" f)
(write-line "// restricted rights notice below appear in all supporting" f)
(write-line "// documentation." f)
(write-line "//" f)
(write-line "// The following program(s) are provided \"as is\" and with all faults." f)
(write-line "// Irné Barnard DOES NOT warrant that the operation of the program(s)" f)
(write-line "// will be uninterrupted and/or error free." f)
(write-line "//" f)
(write-line "// Dialogs for AutoIncr.LSP" f)
(write-line "//" f)
(write-line "// Revision History:" f)
(write-line "//" f)
(write-line
"// -------------------------------------------------------------------------------------"
f
)
(write-line "" f)
(write-line
"// -------------------------------------------------------------------------------------"
f
)
(write-line "// Settings Dialog" f)
(write-line
"// -------------------------------------------------------------------------------------"
f
)
(write-line "AInc_Settings : dialog {" f)
(write-line " label = \"Auto Increment - Settings\";" f)
(write-line " : row {" f)
(write-line " : boxed_radio_column {" f)
(write-line " label = \"Numbering Type\";" f)
(write-line " key = \"Type\";" f)
(write-line " : radio_button { key = \"INT\"; label = \"Integer\"; }" f)
(write-line " : radio_button { key = \"REAL\"; label = \"Decimal Numbers\"; }" f)
(write-line " : radio_button { key = \"BIN\"; label = \"Binary numbering\"; }" f)
(write-line " : radio_button { key = \"OCT\"; label = \"Octal numbering\"; }" f)
(write-line " : radio_button { key = \"HEX\"; label = \"Hexadecimal numbering\"; }" f)
(write-line " : radio_button { key = \"ALPHAU\"; label = \"Alphabetic UPPER CASE\"; }" f)
(write-line " : radio_button { key = \"ALPHAL\"; label = \"Alphabetic lower case\"; }" f)
(write-line " : radio_button { key = \"ROMANU\"; label = \"Roman Numerals UPPER CASEe\"; }" f)
(write-line " : radio_button { key = \"ROMANL\"; label = \"Roman Numerals lower case\"; }" f)
(write-line " }" f)
(write-line " : column {" f)
(write-line
" : row { : text { value = \"Prefix:\"; width = 8; } : edit_box { key = \"Prefix\"; edit_width = 35; }}"
f
)
(write-line
" : row { : text { value = \"Suffix:\"; width = 8; } : edit_box { key = \"Suffix\"; edit_width = 35; }}"
f
)
(write-line
" : row { : text { value = \"Start:\"; width = 8; } : edit_box { key = \"Start\"; edit_width = 11; }"
f
)
(write-line
" : text { value = \"Vector:\"; width = 8; } : edit_box { key = \"Vector\"; edit_width = 11; }"
f
)
(write-line " }" f)
(write-line
" : row { : text { value = \"Digits:\"; width = 8; } : edit_box { key = \"Digits\"; edit_width = 11; }"
f
)
(write-line
" : text { value = \"Precision:\"; width = 8; } : edit_box { key = \"Precision\"; edit_width = 11; }}"
f
)
(write-line
" : boxed_row { label = \"Example:\"; : text { key = \"TypeEg\"; height = 4; value = \"Test\"; }}"
f
)
(write-line " : row { fixed_width = true; alignment = right;" f)
(write-line " : retirement_button { key = \"Load\"; label = \"&Load...\"; }" f)
(write-line " : retirement_button { key = \"Save\"; label = \"&Save...\"; }" f)
(write-line " ok_button; cancel_button;" f)
(write-line " }" f)
(write-line " }" f)
(write-line " }" f)
(write-line "}" f)
(close f)
(load_dialog fn)
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Open dialog for settings
;;; -------------------------------------------------------------------------------------
;;; settings = List containing the settings to be displayed
;;; Result: nil if Cancel is pressed, if OK pressed a list containing the modified
;;; settings.
;;; -------------------------------------------------------------------------------------
(defun AInc:SettingsDlg (settings / dcl settings AInc:TestInt AInc:TestReal AInc:DlgType $min $max
)
(setq dcl (load_dialog_AutoIncr))
(if (new_dialog "AInc_Settings" dcl "1")
(progn
;; Function to show example
(defun AInc:Example (/ str n)
(setq str ""
n (nth 0 settings)
) ;_ end of setq
(repeat 20
(setq str (strcat str
(nth 3 settings)
(AInc:Num2Type n (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
", "
) ;_ end of strcat
n (+ n (nth 1 settings))
) ;_ end of setq
) ;_ end of repeat
(set_tile "TypeEg" (strcat str "..."))
) ;_ end of defun
;; Setup types group, example & en-/disable precision
(defun AInc:DlgType ($value /)
(cond
((wcmatch $value "ALPHA*")
(setq $min 1
$max nil
) ;_ end of setq
(if (< (nth 0 settings) $min)
(progn
(setq settings (AInc:ListReplace settings 0 $min))
(set_tile "Start" (rtos (nth 0 settings)))
) ;_ end of progn
) ;_ end of if
)
((wcmatch $value "ROMAN*")
(setq $min 1
$max 3999
) ;_ end of setq
(if (< (nth 0 settings) $min)
(progn
(setq settings (AInc:ListReplace settings 0 $min))
(set_tile "Start" (rtos (nth 0 settings)))
) ;_ end of progn
) ;_ end of if
(if (> (nth 0 settings) $max)
(progn
(setq settings (AInc:ListReplace settings 0 $max))
(set_tile "Start" (rtos (nth 0 settings)))
) ;_ end of progn
) ;_ end of if
)
((setq $min nil
$max nil
) ;_ end of setq
)
) ;_ end of cond
(if (and (= (cadr (assoc $value AInc#Types)) 0)
(= (type (cadr (assoc $value AInc#Types))) 'REAL)
) ;_ end of and
(progn
(mode_tile "Precision" 0)
(mode_tile "Precision-" 0)
(mode_tile "Precision+" 0)
) ;_ end of progn
(progn
(mode_tile "Precision" 1)
(mode_tile "Precision-" 1)
(mode_tile "Precision+" 1)
) ;_ end of progn
) ;_ end of if
(setq settings (AInc:ListReplace settings 2 $value))
) ;_ end of defun
(action_tile "Type" "(AInc:DlgType $value) (AInc:Example)")
(set_tile "Type" (caddr settings))
(AInc:DlgType (caddr settings))
(AInc:Example)
(defun AInc:TestInt ($key $reason $value $old $min $max / lst item)
(if (and (= $reason 2) (wcmatch $value "*[~0123456789]*"))
(progn
(alert (strcat $value " is not a valid integer.\nPlease try again."))
(set_tile $key $old)
(mode_tile $key 3)
(mode_tile $key 2)
nil
) ;_ end of progn
(if (and $min (< (atoi $value) $min))
(progn
(alert (strcat $value " is less than the minimum.\nPlease try again."))
nil
) ;_ end of progn
(if (and $max (> (atoi $value) $max))
(progn
(alert (strcat $value " is more than the maximum.\nPlease try again."))
nil
) ;_ end of progn
t
) ;_ end of if
) ;_ end of if
) ;_ end of if
) ;_ end of defun
(defun AInc:TestReal ($key $reason $value $old $min $max / lst item)
(if (and (= $reason 2) (wcmatch $value "*[~-.0123456789]*"))
(progn
(alert (strcat $value " is not a valid number.\nPlease try again."))
(set_tile $key $old)
(mode_tile $key 3)
(mode_tile $key 2)
nil
) ;_ end of progn
(if (and $min (< (atoi $value) $min))
(progn
(alert (strcat $value " is less than the minimum.\nPlease try again."))
nil
) ;_ end of progn
(if (and $max (> (atoi $value) $max))
(progn
(alert (strcat $value " is more than the maximum.\nPlease try again."))
nil
) ;_ end of progn
t
) ;_ end of if
) ;_ end of if
) ;_ end of if
) ;_ end of defun
;; Setup pre-, suffix, start, vector, precision & reactor
(set_tile "Start" (rtos (nth 0 settings)))
(action_tile
"Start"
(strcat
"(if (AInc:TestReal $key $reason $value (rtos (nth 0 settings)) $min $max)"
" (setq settings (AInc:ListReplace settings 0 (atof $value)))"
" (progn (set_tile \"Start\" (rtos (nth 0 settings)))" " (mode_tile \"Start\" 2)" " )) "
"(AInc:Example)"
) ;_ end of strcat
) ;_ end of action_tile
(set_tile "Vector" (rtos (nth 1 settings)))
(action_tile
"Vector"
(strcat
"(if (AInc:TestReal $key $reason $value (rtos (nth 1 settings)) nil $max)"
" (setq settings (AInc:ListReplace settings 1 (atof $value)))"
" (progn (set_tile \"Vector\" (rtos (nth 1 settings)))" " (mode_tile \"Vector\" 2)" " )) "
"(AInc:Example)"
) ;_ end of strcat
) ;_ end of action_tile
(set_tile "Prefix" (nth 3 settings))
(action_tile
"Prefix"
"(setq settings (AInc:ListReplace settings 3 $value)) (AInc:Example)"
) ;_ end of action_tile
(set_tile "Suffix" (nth 4 settings))
(action_tile
"Suffix"
"(setq settings (AInc:ListReplace settings 4 $value)) (AInc:Example)"
) ;_ end of action_tile
(set_tile "Precision" (itoa (nth 5 settings)))
(action_tile
"Precision"
(strcat
"(if (AInc:TestInt $key $reason $value (itoa (nth 5 settings)) 0 $max)"
" (setq settings (AInc:ListReplace settings 5 (atoi $value)))"
" (progn (set_tile \"Precision\" (rtos (nth 5 settings)))" " (mode_tile \"Precision\" 2)" " )) "
"(AInc:Example)"
) ;_ end of strcat
) ;_ end of action_tile
(set_tile "Digits" (itoa (nth 6 settings)))
(action_tile
"Digits"
(strcat
"(if (AInc:TestInt $key $reason $value (itoa (nth 6 settings)) 1 $max)"
" (setq settings (AInc:ListReplace settings 6 (atoi $value)))"
" (progn (set_tile \"Digits\" (rtos (nth 6 settings)))" " (mode_tile \"Digits\" 2)" " )) "
"(AInc:Example)"
) ;_ end of strcat
) ;_ end of action_tile
(defun AInc:DlgLoad (/ f str s)
(if (setq f (open (getfiled "Load Increment Settings" (getvar "DWGPREFIX") "inc" 12) "r"))
(progn
(setq str "")
(while (setq s (read-line f)) (setq str (strcat str "\n" s)))
(close f)
(setq settings (read str))
(set_tile "Start" (rtos (nth 0 settings)))
(set_tile "Vector" (rtos (nth 1 settings)))
(set_tile "Type" (nth 2 settings))
(set_tile "Prefix" (nth 3 settings))
(set_tile "Suffix" (nth 4 settings))
(set_tile "Precision" (itoa (nth 5 settings)))
(set_tile "Digits" (itoa (nth 6 settings)))
(AInc:DlgType (nth 2 settings))
(AInc:Example)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(action_tile "Load" "(AInc:DlgLoad)")
(defun AInc:DlgSave (/ f)
(if (setq f (open (getfiled "Save Increment Settings" (getvar "DWGPREFIX") "inc" 5) "w"))
(progn
(prin1 settings f)
(close f)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(action_tile "Save" "(AInc:DlgSave)")
(if (= (start_dialog) 0)
(setq settings nil)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
(unload_dialog dcl)
settings
) ;_ end of defun
;;; -------------------------------------------------------------------------------------
;;; Purge empty groups
;;; -------------------------------------------------------------------------------------
;;; -------------------------------------------------------------------------------------
(defun c:PurgeGroups (/ acad doc grps n str grp)
(setq grps (vla-get-Groups (setq doc (vla-get-ActiveDocument (setq acad (vlax-get-acad-object)))))
n (vla-get-Count grps)
)
(while (>= (setq n (1- n)) 0)
(setq grp (vla-Item grps n))
(if (= (vla-get-Count grp) 0)
(vla-Delete grp)
)
)
(vlax-release-object grps)
(vlax-release-object doc)
(vlax-release-object acad)
(princ)
)
;;; -------------------------------------------------------------------------------------
;;; Create an AutoIncr Group for collecting entities to be incremented
;;; -------------------------------------------------------------------------------------
;;; settings = the list of settings for this group
;;; Result: A newly created AutoIncr group ActiveX object
;;; -------------------------------------------------------------------------------------
(defun AInc:GroupNew (settings / acad doc grps n str grp gd)
(c:PurgeGroups)
;; Get the next free AutoIncr group name
(setq n 0
grps (cdr (assoc -1 (dictsearch (namedobjdict) "ACAD_GROUP")))
)
(while (dictsearch grps (strcat "AutoIncr" (itoa n))) (setq n (1+ n)))
;; Create the new empty group
(setq grps (vla-get-Groups (setq doc (vla-get-ActiveDocument (setq acad (vlax-get-acad-object))))))
(setq grp (vla-Add grps (strcat "AutoIncr" (itoa n)))
gd (entget (vlax-vla-object->ename grp))
gd (subst '(71 . 0) (assoc 71 gd) gd)
)
(entmod gd)
(vlax-ldata-put grp "AInc#Settings" settings)
(vlax-release-object grps)
(vlax-release-object doc)
(vlax-release-object acad)
grp
)
;;; -------------------------------------------------------------------------------------
;;; Get the group & index of a selected item
;;; -------------------------------------------------------------------------------------
;;; en = The ActiveX object of the entity to search
;;; Result: A list containing all the group objects & indexes found or nil if not found
;;; -------------------------------------------------------------------------------------
(defun AInc:GroupGet (en / ed gn gd go n eo eo1 lst)
;; Check if the entity belongs to a group
(if (and (setq ed (cdr (member '(102 . "{ACAD_REACTORS") (entget en))))
(setq eo (vlax-ename->vla-object en))
)
(progn
(while (and (setq gn (assoc 330 ed))
(setq gn (cdr gn))
(setq gd (entget gn))
)
(if (and (eq (cdr (assoc 0 gd)) "GROUP")
(vlax-ldata-get gn "AInc#Settings")
)
(progn
(setq go (vlax-ename->vla-object gn)
eo (vlax-ename->vla-object en)
)
(setq n 0)
(while (and (< n (vla-get-Count go))
(setq eo1 (vla-Item go n))
(/= (vla-get-ObjectID eo) (vla-get-ObjectID eo1))
)
(setq n (1+ n))
)
(setq lst (cons (cons go n) lst))
)
)
(setq ed (cdr (member (assoc 330 ed) ed)))
)
lst
)
;; Not part of a group
nil
)
)
;;; -------------------------------------------------------------------------------------
;;; Insert a selection of entities to a group
;;; -------------------------------------------------------------------------------------
;;; grp = The ActiveX object of the group
;;; lst = A list of enames to add to the group
;;; idx = The index of the 1st new entity, or nil to append
;;; Result: An ActiveX object of the group
;;; -------------------------------------------------------------------------------------
(defun AInc:GroupInsert (grp lst idx / newArray en eo n nextArray)
;; Setup the array of new entities to add
(setq newArray (vlax-make-safearray vlax-vbObject (cons 0 (1- (length lst))))
n 0
)
(foreach en lst
(setq eo (vlax-ename->vla-object en))
(vlax-safearray-put-element newArray n eo)
(setq n (1+ n))
)
;; Check if appending
(if (and idx (< idx (vla-get-Count grp)))
(progn
;; Get the existing entities after the index
(setq nextArray (vlax-make-safearray vlax-vbObject (cons 0 (- (vla-get-Count grp) idx 1)))
n idx
)
(while (< n (vla-get-Count grp))
(vlax-safearray-put-element nextArray (- n idx) (vla-Item grp n))
(setq n (1+ n))
)
;; Remove the entities after the index
(vla-RemoveItems grp nextArray)
)
)
;; Append the new entities to the group
(vla-AppendItems grp newArray)
;; Append next existing entities
(if nextArray
(vla-AppendItems grp nextArray)
)
grp
)
;;; -------------------------------------------------------------------------------------
;;; Renumber the group
;;; -------------------------------------------------------------------------------------
;;; grp = The ActiveX object of the group
;;; -------------------------------------------------------------------------------------
(defun AInc:Renumber (grp / settings n eo num)
(if (setq settings (vlax-ldata-get grp "AInc#Settings"))
(progn
(setq num (car settings)
n 0
)
(while (< n (vla-get-Count grp))
(setq eo (vla-Item grp n))
(vla-put-TextString
eo
(strcat (nth 3 settings)
(AInc:Num2Type num (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
)
)
(setq n (1+ n)
num (+ num (nth 1 settings))
)
)
)
)
)
;;; -------------------------------------------------------------------------------------
;;; Highlight the entity by drawing a bounding box in dashed
;;; -------------------------------------------------------------------------------------
;;; en = The entity ename
;;; c = Colour for the highlight
;;; -------------------------------------------------------------------------------------
(defun AInc:HighlightEnt (en c / ed box ang pt pt1 pt2 pt3 pt4 ang1 dist1)
(setq ed (entget en))
(cond
((wcmatch (cdr (assoc 0 ed)) "M*LEADER")
(setq pt (cdr (assoc 10 ed))
pt1 (list (car pt) (- (cadr pt) (* (getvar "TEXTSIZE") 0.5)) (caddr pt))
pt2 (polar pt1 0.0 (* (getvar "TEXTSIZE") 5.0))
pt3 (polar pt2 (* pi 0.5) (getvar "TEXTSIZE"))
pt4 (polar pt1 (* pi 0.5) (getvar "TEXTSIZE"))
)
)
((wcmatch (cdr (assoc 0 ed)) "MTEXT")
(setq pt (cdr (assoc 10 ed))
ang (cdr (assoc 50 ed))
)
(cond
((= (cdr (assoc 71 ed)) 1) ;Top left
(setq pt1 (polar pt (+ ang (* pi 1.5)) (cdr (assoc 43 ed))))
)
((= (cdr (assoc 71 ed)) 2) ;Top center
(setq pt1 (polar pt (+ ang (* pi 1.5)) (cdr (assoc 43 ed)))
pt1 (polar pt1 (+ ang pi) (* (cdr (assoc 42 ed)) 0.5))
)
)
((= (cdr (assoc 71 ed)) 3) ;Top right
(setq pt1 (polar pt (+ ang (* pi 1.5)) (cdr (assoc 43 ed)))
pt1 (polar pt1 (+ ang pi) (cdr (assoc 42 ed)))
)
)
((= (cdr (assoc 71 ed)) 4) ;Middle left
(setq pt1 (polar pt (+ ang (* pi 1.5)) (* (cdr (assoc 43 ed)) 0.5)))
)
((= (cdr (assoc 71 ed)) 5) ;Middle center
(setq pt1 (polar pt (+ ang (* pi 1.5)) (* (cdr (assoc 43 ed)) 0.5))
pt1 (polar pt1 (+ ang pi) (* (cdr (assoc 42 ed)) 0.5))
)
)
((= (cdr (assoc 71 ed)) 6) ;Middle right
(setq pt1 (polar pt (+ ang (* pi 1.5)) (* (cdr (assoc 43 ed)) 0.5))
pt1 (polar pt1 (+ ang pi) (cdr (assoc 42 ed)))
)
)
((= (cdr (assoc 71 ed)) 7) ;Bottom left
(setq pt1 pt)
)
((= (cdr (assoc 71 ed)) 8) ;Bottom center
(setq pt1 pt
pt1 (polar pt1 (+ ang pi) (* (cdr (assoc 42 ed)) 0.5))
)
)
((= (cdr (assoc 71 ed)) 9) ;Bottom right
(setq pt1 pt
pt1 (polar pt1 (+ ang pi) (cdr (assoc 42 ed)))
)
)
)
(setq pt2 (polar pt1 ang (cdr (assoc 42 ed)))
pt3 (polar pt2 (+ ang (* pi 0.5)) (cdr (assoc 43 ed)))
pt4 (polar pt1 (+ ang (* pi 0.5)) (cdr (assoc 43 ed)))
)
)
(t
(setq box (textbox ed))
(setq box (list (list
(- (car (car box)) (* (car (cadr box)) 0.2))
(- (cadr (car box)) (* (cadr (cadr box)) 0.2))
(- (caddr (car box)) (* (caddr (cadr box)) 0.2))
)
(list
(* (car (cadr box)) 1.4)
(* (cadr (cadr box)) 1.4)
(* (caddr (cadr box)) 1.4)
)
)
)
(setq pt (trans (cdr (assoc 10 ed)) en 0)
pt1 (trans '(1000.0 0.0 0.0) en 0)
ang (+ (angle '(0.0 0.0 0.0) pt1) (cdr (assoc 50 ed)))
ang1 (+ ang (angle '(0.0 0.0 0.0) (car box)))
dist1 (distance '(0.0 0.0 0.0) (car box))
pt1 (polar pt ang1 dist1)
pt2 (polar pt1 ang (car (last box)))
pt3 (polar pt2 (+ ang (* pi 0.5)) (cadr (last box)))
pt4 (polar pt1 (+ ang (* pi 0.5)) (cadr (last box)))
)
)
)
(grdraw pt1 pt2 c 1)
(grdraw pt2 pt3 c 1)
(grdraw pt3 pt4 c 1)
(grdraw pt4 pt1 c 1)
)
;;; -------------------------------------------------------------------------------------
;;; Highlight the entities in the group by drawing a bounding box in green dashed before
;;; the indexed entity, red for the indexed entity & cyan for the rest and draw a gray
;;; dashed line between consecutive entities
;;; -------------------------------------------------------------------------------------
;;; grp = The ActiveX object of the group
;;; idx = if not nil draw the indexed entity highlight in red
;;; -------------------------------------------------------------------------------------
(defun AInc:HighlightGrp (grp idx / n eo en ed pt0 pt1 dist ang c)
(redraw)
(setq n 0
c 3
)
(while (< n (vla-get-Count grp))
(setq eo (vla-Item grp n)
en (vlax-vla-object->ename eo)
ed (entget en)
pt1 (trans (cdr (assoc 10 ed)) en 0)
)
(if (and idx (= idx n))
(progn (AInc:HighlightEnt en 1) (setq c 4))
(AInc:HighlightEnt en c)
)
(if pt0
(progn
(setq dist (distance pt0 pt1)
ang (angle pt0 pt1)
)
(grdraw pt0 (polar pt0 ang (* dist 0.8)) 8 1)
)
)
(setq pt0 pt1
n (1+ n)
)
)
)
;;; -------------------------------------------------------------------------------------
;;; Comand to create a new increment group
;;; -------------------------------------------------------------------------------------
(defun c:AutoIncr (/ en grp)
(c:PurgeGroups)
(redraw)
(if (setq en (AInc:PickEntities AInc#Settings (nth 0 AInc#Settings)))
(progn
(setq grp (AInc:GroupNew AInc#Settings))
(AInc:GroupInsert grp en nil)
(AIncr:EditIncr grp 0)
)
)
(princ)
)
;;; -------------------------------------------------------------------------------------
;;; Comand to edit an existing increment group
;;; -------------------------------------------------------------------------------------
(defun c:EditIncr (/ en grp idx n ans eo settings)
(c:PurgeGroups)
(setq en t)
(while (and en (not grp))
(if (setq en (nentsel "\nPick a text/attrib from the existing increment group: "))
(if (not (setq grp (AInc:GroupGet (car en))))
(princ "\nThat does not belong to an increment group, please try again.")
)
)
)
;; Check for multiple groups, ask user to select one
(if (and (> (length grp) 1) (setq n 0))
(while (not idx)
(AInc:HighlightGrp (car (nth n grp)) (cdr (nth n grp)))
(princ (strcat "\nThe entity belongs to "
(itoa (length grp))
" groups. Currently shown group#"
(itoa (1+ n))
)
)
(initget "Prev Next Yes")
(setq ans (getkword "\nIs this the group you want to edit? [Prev/Next/Yes] <Yes>: "))
(cond
((eq ans "Next") (setq n (fix (rem (1+ n) (length grp)))))
((eq ans "Prev")
(if (= n 0)
(setq n (1- (length grp)))
(setq n (1- n))
)
)
(t
(setq idx (cdr (nth n grp))
grp (car (nth n grp))
)
)
)
)
(setq idx (cdr (nth 0 grp))
grp (car (nth 0 grp))
)
)
(AIncr:EditIncr grp idx)
(redraw)
(princ)
)
;;; -------------------------------------------------------------------------------------
;;; Command to renumber groups
;;; -------------------------------------------------------------------------------------
(defun c:RenumIncr (/ nod grp lst ans n)
(c:PurgeGroups)
(if (setq nod (dictsearch (namedobjdict) "ACAD_GROUP"))
(progn
(setq nod (cdr (assoc -1 nod))
grp (dictnext nod t)
lst nil
)
(while grp
(setq grp (vlax-ename->vla-object (cdr (assoc -1 grp))))
(if (vlax-ldata-get grp "AInc#Settings")
(progn
(AInc:Renumber grp)
(setq lst (cons grp lst))
)
)
(setq grp (dictnext nod))
)
(setq n 0
ans "eXit"
)
(while (and ans
(> (length lst) 0)
(progn
(princ "\nThere are ")
(princ (length lst))
(princ " groups. One's currently highlighted and renumbered.")
(AInc:Renumber (nth n lst))
(AInc:HighlightGrp (nth n lst) nil)
(initget "Next Edit eXplode exiT")
(setq ans (getkword "\nAction [Next/Edit/eXplode/exitT] <exiT>: "))
)
)
(cond
((eq ans "Next") (setq n (rem (1+ n) (length lst))))
((eq ans "Edit") (AIncr:EditIncr (nth n lst) 0))
((eq ans "eXplode")
(setq grp (nth n lst))
(setq lst (vl-remove grp lst))
(vla-Delete grp)
(setq n (min n (1- (length lst))))
)
(t (setq ans nil))
)
)
)
)
(redraw)
(princ)
)
;;; -------------------------------------------------------------------------------------
;;; Edit the group at the specified index
;;; -------------------------------------------------------------------------------------
;;; grp = the group object
;;; idx = the index number
;;; -------------------------------------------------------------------------------------
(defun AIncr:EditIncr (grp idx / en n ans eo settings)
(redraw)
(setq ans t)
(while (and ans
(progn
(AInc:Renumber grp)
(AInc:HighlightGrp grp idx)
(princ (strcat "\n"
(itoa (1+ idx))
"th in group of "
(itoa (vla-get-Count grp))
". Green=Previous Red=Current Cyan=Next"
)
)
(initget "Prev Next Up Down Settings Insert Append Remove Exit")
(setq ans (getkword "Action [Prev/Next/Up/Down/Settings/Insert/Append/Remove/Exit] <Exit>: "))
)
)
(cond
;; Previous
((eq ans "Prev") (setq idx (max 0 (1- idx))))
;; Next
((eq ans "Next") (setq idx (min (1+ idx) (1- (vla-get-Count grp)))))
;; Move Up
((and (eq ans "Up") (< idx (1- (vla-get-Count grp))))
(setq eo (vla-Item grp idx)
en (vlax-vla-object->ename eo)
)
(vlax-Invoke grp 'RemoveItems (list eo))
(setq idx (max 0 (1+ idx)))
(AInc:GroupInsert grp (list en) idx)
)
;; Move Down
((and (eq ans "Down") (> idx 0))
(setq eo (vla-Item grp idx)
en (vlax-vla-object->ename eo)
)
(vlax-Invoke grp 'RemoveItems (list eo))
(setq idx (max 0 (1- idx)))
(AInc:GroupInsert grp (list en) idx)
)
;; Remove
((and (eq ans "Remove") (> (vla-get-Count grp) 0))
(setq eo (vla-Item grp idx)
en (vlax-vla-object->ename eo)
)
(vlax-Invoke grp 'RemoveItems (list eo))
(if (>= idx (vla-get-Count grp))
(setq idx (1- idx))
)
)
;; Insert
((eq ans "Insert")
;; Include Feature 3031153
(setq settings (vlax-ldata-get grp "AInc#Settings")
en t
)
(while en
(if (setq en (AInc:PickEntities settings (+ (nth 0 settings) (* (nth 1 settings) idx))))
(progn
(AInc:GroupInsert grp en idx)
(setq idx (+ idx (length en))) ;Set current position to after inserted
(if (<= (length en) 1)
(progn
(setq en t)
(AInc:Renumber grp) ;Add renumbering after picking
(AInc:HighlightGrp grp idx) ;Add highlight after picking
)
(setq en nil)
)
)
)
)
)
;; Append
((eq ans "Append")
;; Include Feature 3031153
(setq settings (vlax-ldata-get grp "AInc#Settings")
en t
)
(while en
(if (setq en (AInc:PickEntities settings (+ (nth 0 settings) (* (nth 1 settings) (vla-get-Count grp)))))
(progn
(AInc:GroupInsert grp en nil)
(if (<= (length en) 1)
(progn
(setq en t)
(AInc:Renumber grp) ;Add renumbering after picking
(AInc:HighlightGrp grp idx) ;Add highlight after picking
)
(setq en nil)
)
)
)
)
)
;; Settings
((eq ans "Settings")
(setq settings (vlax-ldata-get grp "AInc#Settings"))
(if (or (and (or (= (getvar "CMDDIA") 0)
(> (logand (getvar "CMDACTIVE") (+ 4 16 32 64)) 0)
)
)
)
(setq settings (AInc:SettingsCmd settings))
(setq settings (AInc:SettingsDlg settings))
)
(if settings
(progn
(vlax-ldata-put grp "AInc#Settings" settings)
(setq AInc#Settings settings) ;Fixed bug 3031612
)
)
)
;; Exit
((eq ans "Exit") (setq ans nil) (redraw))
)
)
(princ)
)
;;; -------------------------------------------------------------------------------------
;;; Ask user to pick / select / create extra entities for inclusion to group
;;; -------------------------------------------------------------------------------------
;;; settings = the settings list to use
;;; num = the next number to display
;;; Result : list of enames
;;; -------------------------------------------------------------------------------------
(defun AInc:PickEntities (settings num / mode ans ed n lst ao al al2 str1 str2 space sa)
(setq ans t
mode AInc#Mode
)
(while
(and ans
(princ (strcat "\nThe next number will be ["
(nth 3 settings)
(AInc:Num2Type num (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
"]."
)
)
(cond
((eq mode "Pick")
(initget 128 "SElect Create STop")
(setq ans (nentsel "\nPick an entity [SElect/Create/STop]: "))
)
((eq mode "SElect")
(prompt "\nSelect entities <Enter or Space to cancel>: ")
(setq ans (ssget '((0 . "TEXT,MTEXT,INSERT,ATTRIB.MLEADER"))))
)
((eq mode "Create")
(if (not (and (= (type ans) 'STR)
(wcmatch ans "DText,MText,MLeader,Block")
)
)
(setq ans "DText")
)
(initget 128 "DText MText MLeader Block Pick SElect STop")
(setq ans (getkword (strcat "\nCreate an entity [DText/MText/MLeader/Block/Pick/SElect/STop] <" ans ">: ")))
)
)
)
(cond
((eq ans "Pick") (setq AInc#Mode (setq mode ans)))
((eq ans "SElect") (setq mode ans))
((eq ans "Create") (setq AInc#Mode (setq mode ans)))
((= (type ans) 'PICKSET)
(setq n (sslength ans)
lst nil
)
(while (>= (setq n (1- n)) 0)
(setq ed (entget (ssname ans n)))
(cond
((wcmatch (cdr (assoc 0 ed)) "TEXT,MTEXT,MLEADER,ATTRIB")
(setq lst (cons (cdr (assoc -1 ed)) lst))
)
((wcmatch (cdr (assoc 0 ed)) "INSERT")
(setq ed (vlax-ename->vla-object (cdr (assoc -1 ed))))
(if (and (setq al (vlax-invoke ed 'GetAttributes))
(setq str1 (assoc (vla-get-EffectiveName ed) AInc#BlkAttrS))
(progn
(setq ao nil)
(foreach al2 al
(if (eq (strcase (cdr str1)) (strcase (vla-get-TagString al2)))
(setq ao al2)
)
)
ao
)
)
(setq lst (cons (vlax-vla-object->ename ao) lst))
(progn
(setq al2 nil
str1 ""
str2 ""
)
(foreach ao al
(setq al2 (cons (cons (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))) ao) al2)
;Fixed attribute names with underscores / spaces
str1 (strcat str1 " " (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))))
;Fixed attribute names with underscores / spaces
str2 (strcat str2 "/" (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))))
;Fixed attribute names with underscores / spaces
)
)
(setq str1 (strcat (vl-string-trim " " str1))
str2 (strcat (vl-string-trim "/" str2))
)
(initget str1)
(princ "\nThe block named {")
(princ (vla-get-EffectiveName ed))
(princ "} has not been selected yet.")
(if (setq str1 (getkword (strcat "\nWhich attribute do you want? [" str2 "]: "))) ;Fix for bug 3029986
(progn
(setq lst (cons (vlax-vla-object->ename (setq ao (cdr (assoc str1 al2)))) lst))
;Fix for bug 3029986
;; Only replace the block setting if it exists
(if (assoc (vla-get-EffectiveName ed) AInc#BlkAttrS)
(setq AInc#BlkAttrS
(subst (cons (vla-get-EffectiveName ed) (vla-get-TagString ao))
(assoc (vla-get-EffectiveName ed) AInc#BlkAttrS)
AInc#BlkAttrS
)
)
(setq AInc#BlkAttrS (cons (cons (vla-get-EffectiveName ed) (vla-get-TagString ao)) AInc#BlkAttrS))
)
)
)
)
)
)
)
)
(setq ans nil)
)
((eq ans "DText")
(if (and (= (getvar "TILEMODE") 0)
(= (getvar "CVPORT") 1)
)
(setq space (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
)
(setq sa (vlax-make-safearray vlax-vbdouble '(0 . 2)))
(vlax-safearray-fill sa '(0.0 0.0 0.0))
(setq ao (vla-AddText
space
(strcat (nth 3 settings)
(AInc:Num2Type 100 (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
)
sa
(getvar "TEXTSIZE")
)
)
(while (and (setq ans (grread t (+ 1 2 4 8) 0))
(= (car ans) 5)
)
(vlax-safearray-fill sa (cadr ans))
(vla-put-InsertionPoint ao sa)
(vla-Highlight ao :vlax-true)
)
(if (= (car ans) 3)
(progn
(vlax-safearray-fill sa (cadr ans))
(vla-put-InsertionPoint ao sa)
(vla-Highlight ao :vlax-false)
(setq lst (list (vlax-vla-object->ename ao))
ans nil
)
)
)
)
((eq ans "MText")
(if (and (= (getvar "TILEMODE") 0)
(= (getvar "CVPORT") 1)
)
(setq space (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
)
(setq sa (vlax-make-safearray vlax-vbdouble '(0 . 2)))
(vlax-safearray-fill sa '(0.0 0.0 0.0))
(setq ao (vla-AddText
space
(strcat (nth 3 settings)
(AInc:Num2Type 100 (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
)
sa
(getvar "TEXTSIZE")
)
)
(setq ed (textbox (entget (vlax-vla-object->ename ao))))
(vla-Delete ao)
(setq ao (vla-AddMText
space
sa
(* (caadr ed) 1.2)
(strcat (nth 3 settings)
(AInc:Num2Type 100 (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
)
)
)
(while (and (setq ans (grread t (+ 1 2 4 8) 0))
(= (car ans) 5)
)
(vlax-safearray-fill sa (cadr ans))
(vla-put-InsertionPoint ao sa)
(vla-Highlight ao :vlax-true)
)
(if (= (car ans) 3)
(progn
(vlax-safearray-fill sa (cadr ans))
(vla-put-InsertionPoint ao sa)
(vla-Highlight ao :vlax-false)
(setq lst (list (vlax-vla-object->ename ao))
ans nil
)
)
)
)
((eq ans "MLeader")
(if (and (= (getvar "TILEMODE") 0)
(= (getvar "CVPORT") 1)
)
(setq space (vla-get-PaperSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq space (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
)
(setq sa (vlax-make-safearray vlax-vbdouble '(0 . 2)))
(vlax-safearray-fill sa '(0.0 0.0 0.0))
(setq ao (vla-AddText
space
(strcat (nth 3 settings)
(AInc:Num2Type 100 (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
)
sa
(getvar "TEXTSIZE")
)
)
(setq ed (textbox (entget (vlax-vla-object->ename ao))))
(vla-Delete ao)
(setq sa (vlax-make-safearray vlax-vbdouble '(0 . 5)))
(vlax-safearray-fill sa (list 0.0 0.0 0.0 (caadr ed) 0.0 0.0))
(setq ao (vla-AddMLeader space sa 0))
(vla-put-TextString
ao
(strcat (nth 3 settings)
(AInc:Num2Type 100 (nth 2 settings) (nth 6 settings) (nth 5 settings))
(nth 4 settings)
)
)
(setq sa (vlax-make-safearray vlax-vbdouble '(0 . 2))
al (vlax-make-safearray vlax-vbdouble '(0 . 2))
)
(vlax-safearray-fill sa '(0.0 0.0 0.0))
(while (and (setq ans (grread t (+ 1 2 4 8) 0))
(= (car ans) 5)
)
(vlax-safearray-fill al (cadr ans))
(vla-Move ao sa al)
(vla-Highlight ao :vlax-true)
(vlax-safearray-fill sa (vlax-safearray->list al))
)
(if (= (car ans) 3)
(progn
(vlax-safearray-fill al (cadr ans))
(vla-Move ao sa al)
(vla-Highlight ao :vlax-false)
(setq lst (list (vlax-vla-object->ename ao))
ans nil
)
)
)
)
((eq ans "Block")
(if (not (and (or (= (getvar "CMDDIA") 0)
(> (logand (getvar "CMDACTIVE") (+ 4 16 32 64)) 0)
)
)
)
(initdia)
)
(command "._INSERT")
(while (= (logand (getvar "CMDACTIVE") 1) 1) (command pause))
(setq ed (vlax-ename->vla-object (entlast)))
(if (= (vla-get-HasAttributes ed) :vlax-true)
(if (and (setq al (vlax-invoke ed 'GetAttributes))
(setq ans (assoc (vla-get-EffectiveName ed) AInc#BlkAttrS))
(progn
(setq ao nil)
(foreach al2 al
(if (eq (strcase (cdr ans)) (strcase (vla-get-TagString al2)))
(progn
(setq ao al2)
(AInc:HighlightEnt (vlax-vla-object->ename ao) 2)
)
)
)
ao
)
(progn
(initget "Yes No")
(setq sa (getkword
(strcat "This block was previously selected. You chose the {"
(vla-get-TagString ao)
"} attribute as highlighted in yellow. Do you want to do so again? [Yes/No] <Yes>: "
)
)
)
(or (not sa) (eq sa "Yes"))
)
)
(setq ans nil
lst (list (vlax-vla-object->ename ao))
)
(progn
(setq al2 nil
str1 ""
str2 ""
)
(foreach ao al
(setq al2 (cons (cons (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))) ao) al2)
;Fixed attribute names with underscores / spaces
str1 (strcat str1 " " (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))))
;Fixed attribute names with underscores / spaces
str2 (strcat str2 "/" (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))))
;Fixed attribute names with underscores / spaces
)
)
(setq str1 (vl-string-trim " " str1)
str2 (vl-string-trim "/" str2)
)
(initget str1)
(if (setq str1 (getkword (strcat "\nWhich attribute do you want? [" str2 "]: "))) ;Fix for bug 3029986
(progn
(setq lst (list (vlax-vla-object->ename (setq ao (cdr (assoc str1 al2))))) ;Fix for bug 3029986
ans nil
)
;; Only replace the block setting if it exists
(if (assoc (vla-get-EffectiveName ed) AInc#BlkAttrS)
(setq AInc#BlkAttrS
(subst (cons (vla-get-EffectiveName ed) (vla-get-TagString ao))
(assoc (vla-get-EffectiveName ed) AInc#BlkAttrS)
AInc#BlkAttrS
)
)
(setq AInc#BlkAttrS (cons (cons (vla-get-EffectiveName ed) (vla-get-TagString ao)) AInc#BlkAttrS))
)
)
(setq ans "Block")
)
)
)
(progn
(princ "\nThat block doesn't contain attributes. Try again.")
(setq ans "Block")
)
)
)
((= (type ans) 'LIST)
(setq ed (entget (car ans)))
(cond
((wcmatch (cdr (assoc 0 ed)) "TEXT,MTEXT,MLEADER,ATTRIB")
(setq lst (list (car ans))
ans nil
)
)
((and (> (length ans) 2)
(progn
(setq n (length (last ans))
ao nil
)
(while (and (>= (setq n (1- n)) 0) (not ao))
(setq ed (entget (nth n (last ans))))
(if (eq (cdr (assoc 0 ed)) "INSERT")
(setq ao t)
)
)
)
)
(setq ed (vlax-ename->vla-object (cdr (assoc -1 ed))))
(if (= (vla-get-HasAttributes ed) :vlax-true)
(if
(and (setq al (vlax-invoke ed 'GetAttributes))
(setq ans (assoc (vla-get-EffectiveName ed) AInc#BlkAttrS))
(progn
(setq ao nil)
(foreach al2 al
(if (eq (strcase (cdr ans)) (strcase (vla-get-TagString al2)))
(progn
(setq ao al2)
(AInc:HighlightEnt (vlax-vla-object->ename ao) 2)
)
)
)
ao
)
(progn
(initget "Yes No")
(setq
sa (getkword
(strcat "This block was previously selected. You chose the {"
(vla-get-TagString ao)
"} attribute as highlighted in yellow. Do you want to do so again? [Yes/No] <Yes>: "
)
)
)
(or (not sa) (eq sa "Yes"))
)
)
(setq lst (list (vlax-vla-object->ename ao))
ans nil
)
(progn
(setq al2 nil
str1 ""
str2 ""
)
(foreach ao al
(setq al2 (cons (cons (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))) ao) al2)
;Fixed attribute names with underscores / spaces
str1 (strcat str1 " " (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))))
;Fixed attribute names with underscores / spaces
str2 (strcat str2 "/" (strcase (vl-string-translate " _" "--" (vla-get-TagString ao))))
;Fixed attribute names with underscores / spaces
)
)
(setq str1 (vl-string-trim " " str1)
str2 (vl-string-trim "/" str2)
)
(initget str1)
(if (setq ans (getkword (strcat "\nWhich attribute do you want? [" str2 "]: ")))
(progn
(setq lst (list (vlax-vla-object->ename (cdr (assoc ans al2))))
ans nil
)
;; Only replace the block setting if it exists
(if (assoc (vla-get-EffectiveName ed) AInc#BlkAttrS)
(setq AInc#BlkAttrS
(subst (cons (vla-get-EffectiveName ed) (vla-get-TagString ao))
(assoc (vla-get-EffectiveName ed) AInc#BlkAttrS)
AInc#BlkAttrS
)
)
(setq AInc#BlkAttrS (cons (cons (vla-get-EffectiveName ed) (vla-get-TagString ao)) AInc#BlkAttrS))
)
)
(setq ans "Pick")
)
)
)
(progn
(princ "\nThat block doesn't contain attributes. Try again.")
(setq ans "Pick")
)
)
)
(t
(princ "\nThat type of entity can't contain text. Try again.")
(setq ans "Pick")
)
)
)
(t
(setq ans nil
lst nil
)
)
)
)
lst
)
(princ)
;|«Visual LISP© Format Options»
(120 2 1 2 nil "end of " 100 9 0 0 1 nil T nil T)
;*** DO NOT add text below the comment! ***|;
|
 |
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
|
|
lococad
Utente
Regione: Lombardia
Prov.: Milano
Città: Milano
18 Messaggi |
Inserito il - 23 dicembre 2011 : 17:41:12
|
| Scusa la ignoranza ma funzione anche su Autocad-LT 2008...e come faccio farlo funziona su autocad |
*|* |
|
|
|
Giuseppe Mauro
Amministratore
Regione: Campania
Prov.: Napoli
2705 Messaggi |
Inserito il - 24 dicembre 2011 : 12:43:28
|
Su LT i lisp non possono essere caricati
|
|
|
|
arri
Utente Master
Regione: Lombardia
14951 Messaggi |
|
| |
Discussione |
|
Tools per numerazione incrementale
