Quick Create wblock from Polyline Selection with base point 0,0,0 and place it in a drawing directory (No need to specify name and insertion point of wblock)


;;; Quick Create wblock from Polyline Selection with base point 0,0,0 and place it in a drawing directory
;;; No need to specify name and insertion point of wblock
;;; Special thanks to Alan J. Thompson and Lee Mak

;;; Combined by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)

;;; Lee Mak Quick Wblock Creator
;;; 'Convert' current selection set to selection set required by the Wblock method)
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?91674-Make-selection-set-active

(defun c:wb ( / doc idx lst sel ssc vsl )
(if (setq sel (ssget "P"))
(progn
(repeat (setq idx (sslength sel))
(setq lst (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) lst))
)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
ssc (vla-get-selectionsets doc)
vsl (vla-add ssc (uniqueitem ssc "mywb"))
)
(vla-additems vsl
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
lst
)
)
)
(vla-wblock doc
(vl-filename-mktemp
(vl-filename-base (getvar 'dwgname))
(getvar 'dwgprefix)
".dwg"
)
vsl
)
(vla-delete vsl)
)
)
(princ)
)

(defun uniqueitem ( col key / int rtn )
(setq int 0)
(while
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-item
(list col (setq rtn (strcat key (itoa (setq int (1+ int))))))
)
)
)
)
rtn
)

(vl-load-com) (princ)

(defun c:swc (/ _addgroup _pac add e i ss temp)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
;; RJP simplified & added groups 02.22.2017
(vl-load-com)
(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getdistatparam e (vlax-curve-getendparam e))) 500.))))
(while (< (setq d (+ d v)) l) (setq lst (cons (vlax-curve-getpointatdist e d) lst)))
)
(defun _addgroup (listofobjects / grp grps name)
;; Check that all items in the list are vla-objects
(if (and (vl-every '(lambda (x) (eq (type x) 'vla-object)) listofobjects)
(setq grps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
)
(progn (setq grp (vla-add grps "*"))
(vlax-invoke grp 'appenditems listofobjects)
listofobjects
)
)
)
(initget 0 "Crossing Within")
(setq *swc:opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*swc:opt*)
)
)
; (princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget "L" )
)
(progn
(repeat (setq i (sslength ss))
;; Must be visible on screen for point selection to work
(if (setq temp (ssget (if (eq *swc:opt* "Crossing")
"_CP"
"_WP"
)
(_pac (setq e (ssname ss (setq i (1- i)))))
)
)
(progn
;; Remove boundary from selection so it won't get grouped
(ssdel e temp)
;; Delete boundary
(entdel e)
;; Group objects
(_addgroup
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex temp))))
)
;; Highlight selection
(sssetfirst nil temp)
)
)
)
)
)
(princ)
)

(defun C:WPS ()
(setvar "osmode" 16384)

(command "_.pline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:swc)
(c:wb)
(command "_.erase" "p" "")
(princ)
)

Quick Create wblock from Lasso Selection with base point 0,0,0 and place it in a drawing directory (No need to specify name and insertion point of wblock)


;;; Quick Create wblock from Lasso Selection with base point 0,0,0 and place it in a drawing directory
;;; No need to specify name and insertion point of wblock
;;; Special thanks to Alan J. Thompson and Lee Mak

;;; Combined by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)

;;; Lee Mak Quick Wblock Creator
;;; 'Convert' current selection set to selection set required by the Wblock method)
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?91674-Make-selection-set-active

(defun c:wb ( / doc idx lst sel ssc vsl )
(if (setq sel (ssget "P"))
(progn
(repeat (setq idx (sslength sel))
(setq lst (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) lst))
)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
ssc (vla-get-selectionsets doc)
vsl (vla-add ssc (uniqueitem ssc "mywb"))
)
(vla-additems vsl
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
lst
)
)
)
(vla-wblock doc
(vl-filename-mktemp
(vl-filename-base (getvar 'dwgname))
(getvar 'dwgprefix)
".dwg"
)
vsl
)
(vla-delete vsl)
)
)
(princ)
)

(defun uniqueitem ( col key / int rtn )
(setq int 0)
(while
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-item
(list col (setq rtn (strcat key (itoa (setq int (1+ int))))))
)
)
)
)
rtn
)

(vl-load-com) (princ)

(defun c:swc (/ _addgroup _pac add e i ss temp)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
;; RJP simplified & added groups 02.22.2017
(vl-load-com)
(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getdistatparam e (vlax-curve-getendparam e))) 500.))))
(while (< (setq d (+ d v)) l) (setq lst (cons (vlax-curve-getpointatdist e d) lst)))
)
(defun _addgroup (listofobjects / grp grps name)
;; Check that all items in the list are vla-objects
(if (and (vl-every '(lambda (x) (eq (type x) 'vla-object)) listofobjects)
(setq grps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
)
(progn (setq grp (vla-add grps "*"))
(vlax-invoke grp 'appenditems listofobjects)
listofobjects
)
)
)
(initget 0 "Crossing Within")
(setq *swc:opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*swc:opt*)
)
)
; (princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget "L" )
)
(progn
(repeat (setq i (sslength ss))
;; Must be visible on screen for point selection to work
(if (setq temp (ssget (if (eq *swc:opt* "Crossing")
"_CP"
"_WP"
)
(_pac (setq e (ssname ss (setq i (1- i)))))
)
)
(progn
;; Remove boundary from selection so it won't get grouped
(ssdel e temp)
;; Delete boundary
(entdel e)
;; Group objects
(_addgroup
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex temp))))
)
;; Highlight selection
(sssetfirst nil temp)
)
)
)
)
)
(princ)
)

(defun C:WAS ()
(setvar "osmode" 16384)

(command "_.spline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:swc)
(c:wb)
(command "_.erase" "p" "")
(princ)
)

Lee Mak Quick Wblock Creator – ‘Convert’ current selection set to selection set required by the Wblock method


;;; Lee Mak Quick Wblock Creator
;;; 'Convert' current selection set to selection set required by the Wblock method)
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?91674-Make-selection-set-active

(defun c:wb ( / doc idx lst sel ssc vsl )
(if (setq sel (ssget))
(progn
(repeat (setq idx (sslength sel))
(setq lst (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) lst))
)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
ssc (vla-get-selectionsets doc)
vsl (vla-add ssc (uniqueitem ssc "mywb"))
)
(vla-additems vsl
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
lst
)
)
)
(vla-wblock doc
(vl-filename-mktemp
(vl-filename-base (getvar 'dwgname))
(getvar 'dwgprefix)
".dwg"
)
vsl
)
(vla-delete vsl)
)
)
(princ)
)

(defun uniqueitem ( col key / int rtn )
(setq int 0)
(while
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-item
(list col (setq rtn (strcat key (itoa (setq int (1+ int))))))
)
)
)
)
rtn
)

(vl-load-com) (princ)
(c:wb)

Make Polyline Selection (draw pline, Select Objects Within/Crossing it and delete pline)


;;; Make Polyline Selection (draw pline, Select Objects Within/Crossing it and delete pline)
;;; Created by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)
;;; Special thanks to Alan J. Thompson

(defun c:swc (/ _addgroup _pac add e i ss temp)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
;; RJP simplified & added groups 02.22.2017
(vl-load-com)
(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getdistatparam e (vlax-curve-getendparam e))) 500.))))
(while (< (setq d (+ d v)) l) (setq lst (cons (vlax-curve-getpointatdist e d) lst)))
)
(defun _addgroup (listofobjects / grp grps name)
;; Check that all items in the list are vla-objects
(if (and (vl-every '(lambda (x) (eq (type x) 'vla-object)) listofobjects)
(setq grps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
)
(progn (setq grp (vla-add grps "*"))
(vlax-invoke grp 'appenditems listofobjects)
listofobjects
)
)
)
(initget 0 "Crossing Within")
(setq *swc:opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*swc:opt*)
)
)
; (princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget "L" )
)
(progn
(repeat (setq i (sslength ss))
;; Must be visible on screen for point selection to work
(if (setq temp (ssget (if (eq *swc:opt* "Crossing")
"_CP"
"_WP"
)
(_pac (setq e (ssname ss (setq i (1- i)))))
)
)
(progn
;; Remove boundary from selection so it won't get grouped
(ssdel e temp)
;; Delete boundary
(entdel e)
;; Group objects
(_addgroup
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex temp))))
)
;; Highlight selection
(sssetfirst nil temp)
)
)
)
)
)
(princ)
)

(defun C:PAS ()
(setvar "osmode" 16384)

(command "_.pline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:swc)
(princ)
)

Make Lasso Selection (draw spline, Select Objects Within/Crossing it and delete spline)


;;; Make Lasso Selection (draw spline and Select Objects Within/Crossing it)
;;; Special thanks to Alan J. Thompson

;;; Combined by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)

(defun c:swc (/ _addgroup _pac add e i ss temp)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
;; RJP simplified & added groups 02.22.2017
(vl-load-com)
(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getdistatparam e (vlax-curve-getendparam e))) 500.))))
(while (< (setq d (+ d v)) l) (setq lst (cons (vlax-curve-getpointatdist e d) lst)))
)
(defun _addgroup (listofobjects / grp grps name)
;; Check that all items in the list are vla-objects
(if (and (vl-every '(lambda (x) (eq (type x) 'vla-object)) listofobjects)
(setq grps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
)
(progn (setq grp (vla-add grps "*"))
(vlax-invoke grp 'appenditems listofobjects)
listofobjects
)
)
)
(initget 0 "Crossing Within")
(setq *swc:opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*swc:opt*)
)
)
; (princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget "L" )
)
(progn
(repeat (setq i (sslength ss))
;; Must be visible on screen for point selection to work
(if (setq temp (ssget (if (eq *swc:opt* "Crossing")
"_CP"
"_WP"
)
(_pac (setq e (ssname ss (setq i (1- i)))))
)
)
(progn
;; Remove boundary from selection so it won't get grouped
(ssdel e temp)
;; Delete boundary
(entdel e)
;; Group objects
(_addgroup
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex temp))))
)
;; Highlight selection
(sssetfirst nil temp)
)
)
)
)
)
(princ)
)

(defun C:LAS ()
(setvar "osmode" 16384)

(command "_.spline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:swc)
(princ)
)

Cистемная переменная WHIPTHREAD

Saved from: https://mikhailov-andrey-s.blogspot.co.il/2017/01/autocad-podderzhka-mnogoyadernyh-processorov.html

На данный момент AutoCAD использует несколько ядер многоядерного процессора (multi-threading или многопоточность) только в трех случаях:
•Регенерация 2D-графики (команды РЕГЕН/_REGEN и ОСВЕЖИТЬ/_REDRAW, равно как и команды зумирования и панорамирования)
•Рендеринг изображений в MentalRay
•Открытие файла с внешними ссылками (XREF)

Во всех остальных случаях AutoCAD использует лишь одно ядро процессора и это НИКАК не исправить и не победить. Думаю, что в обозримом будущем AutoCAD не будет поддерживать многоядерность, Хотя, например, Autodesk Inventor с недавнего времени поддерживает многоядерную архитектуру для большинства рабочих операций и процессов, и эта поддержка все растёт и растёт от версии к версии.

Для управления использованием дополнительного процессора или ядра многоядерного процессора в AutoCAD используется системная переменная WHIPTHREAD, которая может принимать значение:

0 – не использовать многопоточность

1 – использование многопоточности только при регенерации чертежа

2 – использование многопоточности только при перерисовке чертежа

3 – использование многопоточности при регенерации и при перерисовке чертежа

По умолчанию установлено значение 1, желательно присвоить 3.

AutoCAD only supports multi-core technology in specific areas of the product, including:

  • 2D regeneration
  • MentalRay rendering

To fully benefit from multi-core processors, you need to use multi-threaded software; AutoCAD is predominantly a single-threaded application.

Send us Performance Feedback 
If you are having performance problems, consider using the Performance Feedback tool, available in AutoCAD 2015 and later.

It can be found on the Performance tab:

User-added image

This tool makes it easy for you record performance and then send Autodesk a log file, which helps us diagnose program areas that need to be addressed.


Note: A CPU-intensive operation that uses 100% of the resources of a single-core processor only uses a maximum of 50% of the CPU for that same operation on a dual-core computer, and only 6% of each CPU on a 16-core computer. This is shown in the following image:

Due to the lack of multi-threading, AutoCAD is not capable of using more than 50% of the CPU on a dual-core computer, so there is no significant performance gain over a single CPU computer except for the areas noted above.

 

Converts a selection of Text objects into separate Text objects


;;------------------=={ Sentence to Words }==-----------------;;
;; ;;
;; Converts a selection of Text objects into separate Text ;;
;; objects for each word, retaining all properties of the ;;
;; original objects. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:sw ( / _splitwords _textwidth ang dxf ent enx fun inc lst pnt sel spc tot wid )

(defun _splitwords ( str / pos )
(if (setq pos (vl-string-position 32 str))
(cons (cons 1 (substr str 1 pos)) (_splitwords (substr str (+ pos 2))))
(list (cons 1 str))
)
)

(defun _textwidth ( enx )
((lambda ( lst ) (- (caadr lst) (caar lst))) (textbox enx))
)

(if (setq sel (ssget "_:L" '((0 . "TEXT") (-4 . "<NOT") (-4 . "") (-4 . "NOT>"))))
(repeat (setq inc (sslength sel))
(setq ent (ssname sel (setq inc (1- inc)))
enx (entget ent)
tot 0.0
lst nil
)
(foreach item (_splitwords (cdr (assoc 1 enx)))
(setq dxf (entget (entmakex (subst item (assoc 1 enx) enx)))
wid (_textwidth dxf)
tot (+ tot wid)
lst (cons (cons dxf wid) lst)
)
)
(if (< 1 (length lst))
(progn
(setq wid (_textwidth enx)
spc (/ (- wid tot) (float (1- (length lst))))
lst (reverse lst)
ang (cdr (assoc 50 enx))
)
(if
(and
(= 0 (cdr (assoc 72 enx)))
(= 0 (cdr (assoc 73 enx)))
)
(setq pnt (cdr (assoc 10 enx)))
(setq pnt (cdr (assoc 11 enx)))
)
(cond
( (= (cdr (assoc 72 enx)) 0)
(setq fun (lambda ( a b ) (+ spc (cdr a))))
)
( (= (cdr (assoc 72 enx)) 1)
(setq fun (lambda ( a b ) (+ spc (/ (+ (cdr a) (cdr b)) 2.0)))
pnt (polar pnt (+ ang pi) (/ (- wid (cdar lst)) 2.0))
)
)
( (= (cdr (assoc 72 enx)) 2)
(setq fun (lambda ( a b ) (+ spc (cdr b)))
pnt (polar pnt (+ ang pi) (- wid (cdar lst)))
)
)
)
(mapcar
(function
(lambda ( a b / dxf )
(setq dxf (car a)
dxf (subst (cons 10 pnt) (assoc 10 dxf) dxf)
dxf (subst (cons 11 pnt) (assoc 11 dxf) dxf)
pnt (polar pnt ang (fun a b))
)
(entmod dxf)
)
)
lst (append (cdr lst) '((nil . 0.0)))
)
(entdel ent)
)
)
)
)
(princ)
)
(c:sw)

Make Polyline Selection (draw pline and Select Objects Within/Crossing it)


;;; Make Polyline Selection (draw pline and Select Objects Within/Crossing it)
;;; Created by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)
;;; Special thanks to Alan J. Thompson

(defun c:SWC (/ _pac add ss i e temp it o a b pts tempC i3 ec)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
(vl-load-com)

(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))) 100.))))
(while (< (setq d (+ d v)) l)
(setq lst (cons (vlax-curve-getPointAtDist e d) lst))
)
)

(initget 0 "Crossing Within")
(setq *SWC:Opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*SWC:Opt*)
)
)

(princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget "L"

)
)
(progn (repeat (setq i (sslength ss))
(if (setq temp (ssget "_WP" (_pac (setq e (ssname ss (setq i (1- i)))))))
(repeat (setq i2 (sslength temp)) (ssadd (ssname temp (setq i2 (1- i2))) add))
)

(if (eq *SWC:Opt* "Crossing")
(progn (vla-getboundingbox (setq o (vlax-ename->vla-object e)) 'a 'b)
(setq pts (mapcar 'vlax-safearray->list (list a b)))
(if (setq tempC (ssget "_C"
(list (caar pts) (cadar pts) 0.)
(list (caadr pts) (cadadr pts) 0.)
)
)
(repeat (setq i3 (sslength tempC))
(if (vlax-invoke
o
'Intersectwith
(vlax-ename->vla-object (setq ec (ssname tempC (setq i3 (1- i3)))))
acExtendNone
)
(ssadd ec add)
)
)
)
)
)
)
(sssetfirst nil add)
(ssget "_I")
)
)
(princ)
)

(defun C:PAS ()
(setvar "osmode" 16384)

(command "_.pline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:swc)
(princ)
)

Change Width Factor for user selected Texts similar to Width Factor of selected “example” text


;;; Change Width Factor for user selected Texts similar to Width Factor of selected "example" text
;;; Created by Igal Averbuh 2017 (based on some existing routines with different approaches)

(defun c:cf (/ ennyi23 wb23 shell23 loui23 el23)
(initget 7)

(setq ent (entget (car (entsel "\nClick on Text with needful Width Factor:"))))
(setq wb23 (cdr (assoc 41 ent)))

(prompt "\nSelect text(s) to change Width Factor.... ")

(setq ennyi23 (ssget '((0 . "*TEXT"))))

(setvar "cmdecho" 0)
(initget 7)

(setq shell23 (sslength ennyi23))

(setq loui23 0)
(while (< loui23 shell23)
(setq el23 (entget (ssname ennyi23 loui23)))
(if (= "TEXT" (cdr (assoc 0 el23)))
(progn
(setq el23 (subst (cons 41 wb23) (assoc 41 el23) el23))
(entmod el23)
)
)
(setq loui23 (1+ loui23))
)
(setvar "cmdecho" 1)
(princ)
)
;(c:cf)

Change Height of user selected Texts similar to Height of selected “example” text


;;; Change Height of user selected Texts similar to Height of selected "example" text
;;; Based on Lee Mak Routine http://www.cadtutor.net/forum/showthread.php?97314-Lisp-to-change-text-height
;;; Modified by Igal Averbuh 2017 (added option to use height of selected "example" text)

(defun c:ct (/ ht ss)
(vl-load-com)

(setq ent (entget (car (entsel "\nClick on Text with needful height:"))))
(setq htt (cdr (assoc 40 ent)))

(if (and (setq ht (cdr (assoc 40 ent)))
(princ "\nSelect Texts to change it Height:")
(setq ss (ssget '((0 . "*TEXT")))))
(foreach x (mapcar 'entget
(vl-remove-if 'listp
(mapcar 'cadr (ssnamex ss))))
(entmod (subst (cons 40 ht) (assoc 40 x) x))))
(princ))
(c:ct)