Re: Автоматическая расстановка блоков на точки
Светлана! Предлагаю вариант для тех кто не шарит в Лиспах но может ими пользоваться. Я так понимаю, что точечки которые надо поменять на УЗ точка находятся в одном слое.Применяю програмку SSX(выделить все)
;;; ssx.lsp
;;; Copyright (C) 1999 by Autodesk, Inc.
;;;
;;; Permission to use, copy, modify, and distribute this software and its
;;; documentation for any purpose and without fee is hereby granted.
;;;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;; ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;; MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;; Larry Knott Version 2.0 7/18/88
;;; Carl Bethea & Jan S. Yoder Version 3.0
;;; Enhancements to (ssx).
;;; 15 March 1990
;;; ----------------------------------------------------------------
;;; DESCRIPTION
;;; SSX.LSP
;;;
;;; "(SSX)" - Easy SSGET filter routine.
;;;
;;; Creates a selection set. Either type "SSX" at the "Command:" prompt
;;; to create a "previous" selection set or type "(SSX)" in response to
;;; any "Select objects:" prompt. You may use the functions "(A)" to add
;;; entities and "(R)" to remove entities from a selection set during
;;; object selection. More than one filter criteria can be used at a
;;; time.
;;;
;;; SSX returns a selection set either exactly like a selected
;;; entity or, by adjusting the filter list, similar to it.
;;;
;;; The initial prompt is this:
;;;
;;; Command: ssx
;;; Select object/<None>: (RETURN)
;;; >>Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector:
;;;
;;; Pressing RETURN at the initial prompt gives you a null selection
;;; mechanism just as (ssx) did in Release 10, but you may select an
;;; entity if you desire. If you do so, then the list of valid types
;;; allowed by (ssget "x") are presented on the command line.
;;;
;;; Select object/<None>: (a LINE selected)
;;; Filter: ((0 . "LINE") (8 . "0") (39 . 2.0) (62 . 1) (210 0.0 0.0 1.0))
;;; >>Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector:
;;;
;;; At this point any of these filters may be removed by selecting the
;;; option keyword, then pressing RETURN.
;;;
;;; >>Layer name to add/<RETURN to remove>: (RETURN)
;;;
;;; Filter: ((0 . "LINE") (39 . 2.0) (62 . 1) (210 0.0 0.0 1.0))
;;; >>Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector:
;;;
;;; If an item exists in the filter list and you elect to add a new item,
;;; the old value is overwritten by the new value, as you can have only
;;; one of each type in a single (ssget "x") call.
;;;
;;;--------------------------------------------------------------------------;
;;;
;;; Find the dotted pairs that are valid filters for ssget
;;; in entity named "ent".
;;;
;;; ssx_fe == SSX_Find_Entity
;;;
(defun ssx_fe (/ data fltr ent)
(setq ent (car (entsel "\nSelect object <None>: ")))
(if ent
(progn
(setq data (entget ent))
(foreach x '(0 2 6 7 8 39 62 66 210) ; do not include 38
(if (assoc x data)
(setq fltr
(cons (assoc x data) fltr)
)
)
)
(reverse fltr)
)
)
)
;;;
;;; Remove "element" from "alist".
;;;
;;; ssx_re == SSX_Remove_Element
;;;
(defun ssx_re (element alist)
(append
(reverse (cdr (member element (reverse alist))))
(cdr (member element alist))
)
)
;;;
;;; INTERNAL ERROR HANDLER
;;;
(defun ssx_er (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(if (/= s "Function cancelled")
(princ (acet-str-format "\nError: %1" s))
)
(if olderr (setq *error* olderr)) ; Restore old *error* handler
(princ)
)
;;;
;;; Get the filtered sel-set.
;;;
;;;
(defun ssx (/ olderr fltr)
(gc) ; close any sel-sets
(setq olderr *error*
*error* ssx_er
)
(setq fltr (ssx_fe))
(ssx_gf fltr)
)
;;;
;;; Build the filter list up by picking, selecting an item to add,
;;; or remove an item from the list by selecting it and pressing RETURN.
;;;
;;; ssx_gf == SSX_Get_Filters
;;;
(defun ssx_gf (f1 / t1 t2 t3 f1 f2)
(while
(progn
(cond (f1 (prompt "\nCurrent filter: ") (prin1 f1)))
(initget
"Block Color Entity Flag LAyer LType Pick Style Thickness Vector")
(setq t1 (getkword
"\nEnter filter option [Block name/Color/Entity/Flag/LAyer/LType/Pick/Style/Thickness/Vector]: "))
)
(setq t2
(cond
((eq t1 "Block") 2) ((eq t1 "Color") 62)
((eq t1 "Entity") 0) ((eq t1 "LAyer") 8)
((eq t1 "LType") 6) ((eq t1 "Style") 7)
((eq t1 "Thickness") 39) ((eq t1 "Flag" ) 66)
((eq t1 "Vector") 210)
(T t1)
)
)
(setq t3
(cond
((= t2 2) (getstring "\n>>Enter block name to add <RETURN to remove>: "))
((= t2 62) (initget 4 "?")
(cond
((or (eq (setq t3 (getint
"\n>>Enter color number to add [?] <RETURN to remove>: ")) "?")
(> t3 256))
(ssx_pc) ; Print color values.
nil
)
(T
t3 ; Return t3.
)
)
)
((= t2 0) (getstring "\n>>Enter entity type to add <RETURN to remove>: "))
((= t2 8) (getstring "\n>>Enter layer name to add <RETURN to remove>: "))
((= t2 6) (getstring "\n>>Enter linetype name to add <RETURN to remove>: "))
((= t2 7)
(getstring "\n>>Enter text style name to add <RETURN to remove>: ")
)
((= t2 39) (getreal "\n>>Enter thickness to add <RETURN to remove>: "))
((= t2 66) (if (assoc 66 f1) nil 1))
((= t2 210)
(getpoint "\n>>Specify extrusion Vector to add <RETURN to remove>: ")
)
(T nil)
)
)
(cond
((= t2 "Pick") (setq f1 (ssx_fe) t2 nil)) ; get entity
((and f1 (assoc t2 f1)) ; already in the list
(if (and t3 (/= t3 ""))
;; Replace with a new value...
(setq f1 (subst (cons t2 t3) (assoc t2 f1) f1))
;; Remove it from filter list...
(setq f1 (ssx_re (assoc t2 f1) f1))
)
)
((and t3 (/= t3 ""))
(setq f1 (cons (cons t2 t3) f1))
)
(T nil)
)
)
(if f1 (setq f2 (ssget "_x" f1)))
(setq *error* olderr)
(if (and f1 f2)
(progn
(princ (acet-str-format "\n%1 found. " (itoa (sslength f2))))
f2
)
(progn (princ "\n0 found.") (prin1))
)
)
;;;
;;; Print the standard color assignments.
;;;
;;;
(defun ssx_pc ()
(if textpage (textpage) (textscr))
(princ "\n ")
(princ "\n Color number | Standard meaning ")
(princ "\n ________________|____________________")
(princ "\n | ")
(princ "\n 0 | <BYBLOCK> ")
(princ "\n 1 | Red ")
(princ "\n 2 | Yellow ")
(princ "\n 3 | Green ")
(princ "\n 4 | Cyan ")
(princ "\n 5 | Blue ")
(princ "\n 6 | Magenta ")
(princ "\n 7 | White ")
(princ "\n 8...255 | -Varies- ")
(princ "\n 256 | <BYLAYER> ")
(princ "\n \n\n\n")
)
;;;
;;; C: function definition.
;;;
(defun c:ssx ()
(ssx)
(princ)
)
(princ "\n\tType \"ssx\" at a Command: prompt or ")
(princ "\n\t(ssx) at any object selection prompt. ")
(princ)
Выделяю все точки, а затем меняю их на образец заранее заготовленного УЗ точка(в зависимости от масштаба).
(defun c:frto(/ ACTDOC COPOBJ ERRCOUNT EXTLST
EXTSET FROMCEN LAYCOL MAXPT CURLAY
MINPT OBJLAY OKCOUNT OLAYST
SCLAY TOCEN TOOBJ VLAOBJ *ERROR* ASK)
(vl-load-com)
(defun *ERROR*(msg)
(if olaySt (vla-put-Lock objLay olaySt)); end if
(vla-EndUndoMark actDoc)(princ)); end of *ERROR*
(defun GetBoundingCenter(vlaObj / blPt trPt cnPt)
(vla-GetBoundingBox vlaObj 'minPt 'maxPt)
(setq blPt(vlax-safearray->list minPt)
trPt(vlax-safearray->list maxPt)
cnPt(vlax-3D-point
(list
(+(car blPt)(/(-(car trPt)(car blPt))2))
(+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))
(+(caddr blPt)(/(-(caddr trPt)(caddr blPt))2)) ;_<<< Заменили
)))); end of GetBoundingCenter
(setq extSet(ssget "_I"))
(while (not (setq toObj(entsel "\n+++ Select source object -> ")))
(princ "\nSource objects isn't selected!"))
(if(not extSet)
(progn
(princ "\n+++ Select destination objects and press Enter <- ")
(setq extSet(ssget "_:L")))); end if
(if(not extSet)(princ "\nDestination objects isn't selected!")); end if
(if (and extSet toObj)
(progn
(initget "Yes No")
(setq ask (getkword "\nRemove source object [Yes/No] <No>:"))
(setq actDoc (vla-get-ActiveDocument(vlax-get-Acad-object))
layCol (vla-get-Layers actDoc)
extLst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp
(mapcar 'cadr(ssnamex extSet))))
vlaObj (vlax-ename->vla-object(car toObj))
objLay (vla-Item layCol (vla-get-Layer vlaObj))
olaySt (vla-get-Lock objLay)
fromCen (GetBoundingCenter vlaObj)
errCount 0 okCount 0); end setq
(vla-StartUndoMark actDoc)
(foreach obj extLst
(setq toCen (GetBoundingCenter obj)
scLay (vla-Item layCol (vla-get-Layer obj)));end setq
(if(/= :vlax-true(vla-get-Lock scLay))
(progn
(setq curLay(vla-get-Layer obj))
(vla-put-Lock objLay :vlax-false)
(setq copObj(vla-copy vlaObj))
(vla-Move copObj fromCen toCen)
(_kpblc-ent-properties-copy obj copObj)
(vla-put-Layer copObj curLay)
(vla-put-Lock objLay olaySt)
(vla-Delete obj)
(setq okCount(1+ okCount))
); end progn
(setq errCount(1+ errCount))
); end if
); end foreach
(princ (strcat "\n" (itoa okCount) " were changed. "
(if(/= 0 errCount)(strcat (itoa errCount) " were on locked layer! ") "")))
(if (= ask "Yes")
(if(/= :vlax-true(vla-get-Lock objLay))
(vla-Delete vlaObj)
(princ "\nSource object on locked layer! ")))
(vla-EndUndoMark actDoc)); end progn
(princ "\nSource object isn't selected! ")
); end if
(princ)); end of c:frto
;|=============================================================================
* Функция копирования настроек примитивов
* Параметры вызова:
* source примитив-источник (vla)
* dest примитив-получатель (vla)
* Выполняется копирование всех настроек (кроме точек, координат и т.п.), если
* это возможно. Копирование радиусов дуг и окружностей не выполняется.
* Контроль и преобразование параметров не выполняется.
* Примеры вызова:
(_kpblc-ent-properties-copy (vlax-ename->vla-object (car (entsel))) (vlax-ename->vla-object (car (entsel))))
* URL http://www.arcada.com.ua/forum/viewtopi … p;start=15
=============================================================================|;
(defun _kpblc-ent-properties-copy (source dest)
(foreach prop '("Angle" "Layer" "Linetype" "LinetypeScale" "Lineweight"
"Normal" "PlotStyleName" "Thickness" "Color" "Visible"
"Closed" ;|"ConstantWidth" ; не копируется|; "Elevation" "LinetypeGeneration"
"LinetypeScale" ;|"StartAngle" "EndAngle" ; не копируются|; "Alignment"
"Backward" "Height" "ObliqueAngle" "Rotation" "ScaleFactor" "StyleName"
"TextGenerationFlag" "TextHeight" "UpsideDown" "AttachmentPoint" "BackgroundFill"
"DrawingDirection" "LineSpacingDistance" "LineSpacingFactor" "LineSpacingStyle" "Width"
"XScaleFactor" "YScaleFactor" "ZScaleFactor" ;| Viewport|; "ArcSmoothness" "CustomScale"
"Direction" "DisplayLocked" "GridOn" "LensLength" "ModelView" "ShadePlot" "SheetView"
"SnapBasePoint" "SnapOn" "SnapRotationAngle" "StandardScale" "Target" "TwistAngle"
"UCSIconAtOrigin" "UCSIconOn" "UCSPerViewport" "ViewportOn")
(if (and (vlax-property-available-p source prop)(vlax-property-available-p dest prop t))
(_kpblc-error-catch
'(lambda ()(vlax-put-property dest prop (vlax-get-property source prop))) nil)))) ;_ end of defun
;|=============================================================================
* Оболочка отлова ошибок.
* Параметры вызова:
* protected-function — "защищаемая" функция
* on-error-function — функция, выполняемая в случае ошибки
* URL http://www.arcada.com.ua/forum/viewtopi … p;start=15
=============================================================================|;
(defun _kpblc-error-catch
(protected-function on-error-function / catch_error_result)
(setq catch_error_result (vl-catch-all-apply protected-function))
(if (and (vl-catch-all-error-p catch_error_result) on-error-function)
(apply on-error-function
(list (vl-catch-all-error-message catch_error_result)))
catch_error_result)) ;_ end of defun
Эти две програмки скачал где то на форуме. Сам пользуюсь, горя не знаю, хоть полторы тыщи. Если точки с Credo ЦММ, то там можно сразу поменять, но я так не делаю. Вот. Может наумничал но нехотел.
