AutoCAD • AutoLISP • Programlama • Püfler • Komutlar • Terimler • Eğitim
aLd • TCad • FacadeCAD • Cephe Kot • HQ Library • FreeMUST • Pasdoc.A
Forumlar > AutoLISP > Blokları sayma lispi
28.11.2011 13:05    
citi01
Ben daha önceden kullanıyorum ama sitede bulamdım. blokları sayan bir lisp vardı. örneğin ben zayıf akım projesi çiziyorum projedeki bütün duman dedektörlerini bana sayıyordu bu lisp hatırlayan varsa acil yardım lazım arkadaşlar

28.11.2011 19:09    
ehya
Autocadin bcount komutu bu işi yapıyor. lispe gerek yok.

29.11.2011 18:47    
citi01
Teşekkür ederim, nasıl kullanıyorum komutu yazabilirmisin hiç kullanmadım.

30.11.2011 06:54    
ehya
:)
komutu çalıştır.
paftanı seçip enter yap.

02.12.2011 21:27    
citi01
Bende 2007 kurulu o komut yok

03.12.2011 06:59    
ehya
Autocad sanırım 14 sürümünden beri bu komut var. bu komut autocad'in express menüsünde yer alan bir komuttur. express menü yüklü değil ise yüklemelisiniz.

03.02.2012 11:40    
asencer
yabancı bir siteden aldım. blok saymaktan ötesini yapıyor. benim çok işime yaradı. umarım sizlere de yardımcı olur.
iyi çalışmalar.

Kod:

;;---------=={ Count.lsp - Advanced Block Counter }==---------;;
;;                                                            ;;
;;  Program will count the number of occurrences of all or    ;;
;;  selected standard and dynamic blocks in a drawing.        ;;
;;                                                            ;;
;;  The resultant count data is printed to the command line   ;;
;;  and may be optionally written to either a Text or CSV     ;;
;;  file, or, should the program is run in an AutoCAD Version ;;
;;  which supports a Table Object, the data may also be       ;;
;;  displayed in an AutoCAD Table.                            ;;
;;                                                            ;;
;;  All Table & File Headings and Block Preview may be        ;;
;;  altered using the Settings dialog.                        ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Version 1.0    -    05-06-2010                            ;;
;;                                                            ;;
;;  First Release.                                            ;;
;;------------------------------------------------------------;;
;;  Version 1.1    -    06-06-2010                            ;;
;;                                                            ;;
;;  Updated code to include settings dialog.                  ;;
;;  Added Undo Marks.                                         ;;
;;------------------------------------------------------------;;
;;  Version 1.2    -    06-06-2010                            ;;
;;                                                            ;;
;;  Fixed bug with 64-bit systems.                            ;;
;;------------------------------------------------------------;;
;;  Version 1.3    -    02-03-2011                            ;;
;;                                                            ;;
;;  Program completely rewritten.                             ;;
;;  Updated code to work without error on 64-bit systems by   ;;
;;  fixing bug with ObjectID subfunction - my thanks go to    ;;
;;  Jeff M for helping me solve this problem.                 ;;
;;  Added ability to write block count to Text/CSV Files.     ;;
;;------------------------------------------------------------;;

(defun c:blcksay

  ( /

   ;;  --=={ Local Functions }==--

   *error*
   _addtable
   _assoc++
   _countsettings
   _endundo
   _getblockname
   _getobjectid
   _getsavepath
   _is64bit
   _msgbox
   _open
   _padbetween
   _readconfig
   _startundo
   _writeconfig
   _writedcl

   ;;  --=={ Local Variables }==--

   acdoc
   acspc
   args
   blocks
   bt
   btitle
   cfgfname
   column
   ct
   ctitle
   data
   dc
   dcfname
   dctitle
   del
   doc
   file
   hasprev
   hastitle
   hp
   ht
   i
   key
   l
   ln
   lst
   maxl
   mt
   mtitle
   mutter
   n
   opt
   pt
   ptitle
   row
   rowitem
   savepath
   space
   ss
   sym
   symlist
   table
   tile
   title
   vallist
   value
   versionnumber

   ;; --=={ Global Variables }==--

   ; -None-

  )

  (vl-load-com)
 
  (setq VersionNumber "1-3")

  ;;----------------------------------------------------------;;
  ;;                     Local Functions                      ;;
  ;;----------------------------------------------------------;;

  (defun *error* ( msg )
   
    (if dc     (unload_dialog dc))
    (if acdoc  (_EndUndo acdoc))
    (if mutter (setvar 'NOMUTT mutter))
    (if file   (setq file (close file)))
   
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )

  ;............................................................;

  (defun _StartUndo ( doc ) (_EndUndo doc)
    (vla-StartUndoMark doc)
  )

  ;............................................................;

  (defun _EndUndo ( doc )
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )

  ;............................................................;

  (defun _GetSavePath ( / tmp )
    (cond     
      ( (setq tmp (getvar 'ROAMABLEROOTPREFIX))

        (or (eq ""  (substr tmp (strlen tmp)))
            (setq tmp (strcat tmp ""))
        )
        (strcat tmp "Support")
      )
      ( (setq tmp (findfile "ACAD.pat"))

        (setq tmp (vl-filename-directory tmp))

        (and (eq ""  (substr tmp (strlen tmp)))
             (setq tmp (substr tmp (1- (strlen tmp))))
        )
        tmp
      )
    )
  )

  ;............................................................;

  (defun _WriteConfig ( fname lst / ofile )

    (if (setq ofile (open fname "w"))
      (progn       
        (foreach x lst (write-line (vl-prin1-to-string x) ofile))
       
        (setq ofile (close ofile))
        t
      )
    )
  )

  ;............................................................;
 
  (defun _ReadConfig  ( fname lst / ofile )

    (if (and (setq fname (findfile fname))
             (setq ofile (open fname "r")))
      (progn         
        (foreach x lst (set x (read (read-line ofile))))
       
        (setq ofile (close ofile))
        lst
      )
    )
  )

  ;............................................................;

  (defun _Assoc++ ( key lst )
    (
      (lambda ( pair )
        (if pair
          (subst (list key (1+ (cadr pair))) pair lst)
          (cons  (list key 1) lst)
        )
      )
      (assoc key lst)
    )
  )

  ;............................................................;

  (defun _PadBetween ( s1 s2 ch ln )
    (
      (lambda ( l1 l2 ch )
        (while (< (+ (length l1) (length l2)) ln) (setq l2 (cons ch l2)))
        (vl-list->string (append l1 l2))
      )
      (vl-string->list s1)
      (vl-string->list s2) (ascii ch)
    )
  )

  ;............................................................;
 
  (defun _GetBlockName ( obj )
    (vlax-get-property obj
      (if (vlax-property-available-p obj 'EffectiveName) 'EffectiveName 'Name)
    )
  )

  ;............................................................;

  (defun _Is64Bit nil (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE")))

  ;............................................................;

  (defun _GetObjectID ( doc obj )
    (if (_Is64Bit)
      (vla-get-Objectid32 obj)
      (vla-get-Objectid   obj)
    )
  )

  ;............................................................;

  (defun _MsgBox ( title flags msg / WSHShell result )
     
    (setq WSHShell (vlax-create-object "WScript.Shell"))
    (setq result   (vlax-invoke WSHShell 'Popup msg 0 title flags))
    (vlax-release-object WSHShell)
    result
  )

  ;............................................................;

  (defun _WriteDCL ( fname / ofile )

    (if (not (findfile fname))
     
      (if (setq ofile (open fname "w"))
        (progn
          (foreach str

            '("//------------=={ Count.dcl Dialog Definition }==-----------//"
              "//                                                          //"
              "//  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com     //"
              "//----------------------------------------------------------//"
              ""
              "ed12 : edit_box { edit_width = 12; fixed_width = true; alignment = centered; }"
              "tog  : toggle   { alignment = centered; }"
              ""
              "//----------------------------------------------------------//"
              "//                  Main Dialog Definition                  //"
              "//----------------------------------------------------------//"
              ""
              "count : dialog { key = "dctitle"; spacer;"
              ""
              "  : image { key = "sep1"; width = 33.26; height = 0.74; color = -15; }"
              ""
              "  : row {"
              "    : column { spacer; : ed12 { key = "ptitle"; } }"
              "    spacer;"
              "    : column {"
              "      : ed12 { key = "mtitle"; }"
              "      : ed12 { key = "btitle"; }"
              "    }"
              "    spacer;"
              "    : column { spacer; : ed12 { key = "ctitle"; } }"
              "  }"
              "  spacer;"
              "  : image { key = "sep2"; width = 33.26; height = 0.74; color = -15; }"
              ""
              "  : row {"
              "    spacer;"
              "    : tog { label = "Block Preview"; key = "hasprev" ; }"
              "    : tog { label = "Table Title";   key = "hastitle"; }"
              "    spacer;"
              "  }"
              "  : image { key = "sep3"; width = 33.26; height = 0.74; color = -15; }"
              "  spacer;"
              ""
              "  ok_cancel;"
              "}"
              "//----------------------------------------------------------//"
              "//                       End of File                        //"
              "//----------------------------------------------------------//"
             )
             (write-line str ofile)
          )
          (setq ofile (close ofile))
          t
        )
      )
      t
    )
  )

  ;............................................................;

  (defun _CountSettings ( fname dctitle args / dc mt pt bt ct hp ht )
   
    (cond
      ( (not (_WriteDCL fname))

        (_MsgBox "Warning" 16 "DCL File Could not be Written")
        (princ "\n** Dialog File Could not be Written")
      )
      ( (<= (setq dc (load_dialog fname)) 0)

        (_MsgBox "Warning" 16 "Dialog File not Found")
        (princ "\n** Dialog File not Found **")
      )
      ( (not (new_dialog "count" dc))

        (_MsgBox "Warning" 16 "Dialog Could not be Loaded")
        (princ "\n** Dialog Could not be Loaded **")
        (setq dc (unload_dialog dc))
      )
      (t
        (set_tile "dctitle" dctitle)

        (foreach x '("sep1" "sep2" "sep3")
          (start_image x) (mapcar 'vector_image '(0 0) '(6 5) '(300 300) '(6 5) '(8 7)) (end_image)
        )
        (mapcar 'set '(mt pt bt ct hp ht) (mapcar 'eval args))

        (foreach x args
          (set_tile (strcase (vl-princ-to-string x) t) (eval x))
        )
        (mode_tile "mtitle" (- 1 (atoi ht)))
        (mode_tile "ptitle" (- 1 (atoi hp)))
       
        (mapcar
         '(lambda ( tile sym )
            (action_tile tile (strcat "(setq " sym " $value)"))
          )
         '("mtitle" "ptitle" "btitle" "ctitle") '("mt" "pt" "bt" "ct")
        )
        (action_tile "hasprev"  "(mode_tile "ptitle" (- 1 (atoi (setq hp $value))))")
        (action_tile "hastitle" "(mode_tile "mtitle" (- 1 (atoi (setq ht $value))))")
       
        (action_tile "accept"   "(mapcar 'set args (list mt pt bt ct hp ht)) (done_dialog)")
        (start_dialog)
        (setq dc (unload_dialog dc))
      )
    )
    (mapcar 'eval args)
  )

  ;............................................................;
     
  (defun _AddTable ( doc space pt data hastitle title hasprev ptitle / _itemp )

    (defun _itemp ( collection item )
      (if
        (not
          (vl-catch-all-error-p
            (setq item
              (vl-catch-all-apply 'vla-item (list collection item))
            )
          )
        )
        item
      )
    )

    (
      (lambda ( table blocks ) (vla-put-RegenerateTableSuppressed table :vlax-true) (vla-put-StyleName table (getvar 'CTABLESTYLE))
        (if hasprev
          (progn (vla-SetText table 1 0 ptitle)
            (
              (lambda ( row )
                (mapcar
                  (function
                    (lambda ( block ) (setq row (1+ row)) (vla-SetCellType table row 0 acBlockCell)
                      (vlax-invoke table
                        (if (_Is64Bit)
                          'SetBlockTableRecordId32
                          'SetBlockTableRecordID
                        )
                        row 0 (_GetObjectID doc (_itemp blocks block)) :vlax-true
                      )
                    )
                  )
                  (mapcar 'car (cdr data))
                )
              )
              1
            )
          )
        )
        (
          (lambda ( row )
            (mapcar
              (function
                (lambda ( rowitem ) (setq row (1+ row))
                  (
                    (lambda ( column )
                      (mapcar
                        (function
                          (lambda ( item )
                            (vla-SetText table row
                              (setq column (1+ column)) item
                            )
                          )
                        )
                        rowitem
                      )
                    )
                    (if hasprev 0 -1)
                  )
                )
              )
              data
            )
          )
          0
        )
        (if hastitle
          (vla-SetText table 0 0 title)
          (vla-deleterows table 0 1)   
        )
        (vla-put-RegenerateTableSuppressed table :vlax-false)
        table
      )
      (
        (lambda ( textheight )
          (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (+ (if hasprev 1 0) (length (car data))) (* 1.8 textheight)
            (* textheight
              (apply 'max
                (cons (/ (strlen title) (length (car data)))
                  (mapcar 'strlen (apply 'append data))
                )
              )
            )
          )
        )
        (vla-getTextHeight
          (_itemp
            (_itemp
              (vla-get-Dictionaries doc) "ACAD_TABLESTYLE"
            )
            (getvar 'CTABLESTYLE)
          )
          acDataRow
        )
      )
      (vla-get-blocks doc)
    )
  )

  ;............................................................;

  (defun _Open ( target / Shell result )
   
    (setq Shell (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application"))

    (setq result
      (and (or (eq 'INT (type target)) (setq target (findfile target)))
        (not
          (vl-catch-all-error-p
            (vl-catch-all-apply 'vlax-invoke (list Shell 'Open target))
          )
        )
      )
    )
   
    (vlax-release-object Shell)
    result
  )

  ;;----------------------------------------------------------;;
  ;;                       Main Routine                       ;;
  ;;----------------------------------------------------------;;

  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
        acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace))
  )

  (if (not (vl-file-directory-p (setq SavePath (_GetSavePath))))
    (progn
      (princ "\n** Save Path not Valid **") (exit)
    )
  )

  (setq dcfname    (strcat SavePath "\\LMAC_Count_V" VersionNumber ".dcl")
        cfgfname   (strcat SavePath "\\LMAC_Count_V" VersionNumber ".cfg")
        dctitle    (strcat "Count V" (vl-string-translate "-" "." VersionNumber) " - Settings")
  )

  (setq SymList '(mtitle ptitle btitle ctitle hasprev hastitle)
        ValList  (list "Block Data" "Preview" "Block Name" "Count" "1" "1")
  )
 
  (or (findfile cfgfname)
      (_WriteConfig cfgfname ValList)
  )
  (_ReadConfig cfgfname SymList)

  (mapcar '(lambda ( sym value ) (or (boundp sym) (set sym value))) SymList ValList)

  ;............................................................;

  (setq mutter (getvar 'NOMUTT))
  (setvar 'NOMUTT 1)
  (princ "\nSelect Blocks to Count <All> : ")

  (cond
    (
      (not
        (progn
          (setq ss
            (cond
              ( (ssget      '((0 . "INSERT"))) )
              ( (ssget "_X" '((0 . "INSERT"))) )
            )
          )
          (setq mutter (not (setvar 'NOMUTT mutter)))
          ss
        )
      )

      (princ "\n--> No Blocks Found.")
    )
    (
      (progn
        (vlax-for obj (setq ss (vla-get-ActiveSelectionSet acdoc))
          (if
            (zerop
              (logand 45
                (cdr
                  (assoc 70
                    (tblsearch "BLOCK"
                      (setq n (_GetBlockName obj))
                    )
                  )
                )
              )
            )
            (setq l (_Assoc++ n l))
          )
        )
        (vla-delete ss)
        (setq i 0 l
          (vl-sort
            (mapcar
              (function
                (lambda ( x )
                  (if (< i (cadr x)) (setq i (cadr x))) (list (car x) (itoa (cadr x)))
                )
              )
              l
            )
            (function (lambda ( a b ) (< (car a) (car b))))
          )
        )
      )
      (setq maxL (- 57 (strlen (itoa i))))

      (princ (strcat "\n" (_PadBetween "Block Name" "Count" "." 60)))
      (princ (strcat "\n" (_PadBetween "" "" "-" 60)))

      (foreach x l
        (princ (strcat "\n" (_PadBetween (substr (car x) 1 maxL) (cadr x) "." 60)))
      )     
      (princ (strcat "\n" (_PadBetween "" "" "-" 60)))
      (terpri)
     
      (if (vlax-method-applicable-p acspc 'AddTable)
        (progn
          (while
            (progn (initget "Table File Settings Exit")
              (setq opt (getkword "\nOutput [Table/File/Settings] <Exit>: "))

              (cond
                (
                  (or (null opt) (eq "Exit" opt)) nil
                )
                (
                  (and (eq "Table" opt) (setq pt (getpoint "\nSpecify Point for Table: ")))

                  (_StartUndo acdoc)                 
                  (_AddTable acdoc acspc (trans pt 1 0) (cons (list btitle ctitle) l) (eq "1" hastitle) mtitle (eq "1" hasprev) ptitle)
                  (_EndUndo   acdoc)                 
                  nil
                )
                (
                  (eq "Settings" opt)

                  (mapcar 'set SymList (_CountSettings dcfname dctitle SymList))
                )
                (
                  (and (eq "File" opt)
                    (setq *file*
                      (getfiled "Create Output File"
                        (vl-filename-directory (cond ( *file* ) ( (getvar 'DWGPREFIX) ))) "csv;txt" 1
                      )
                    )
                  )

                  (if (setq file (open *file* "w"))
                    (cond
                      (
                        (eq ".CSV" (strcase (vl-filename-extension *file*)))

                        (if (eq "1" hastitle) (write-line mtitle file))

                        (foreach line (cons (list btitle ctitle) l)
                          (write-line (strcat (car line) "," (cadr line)) file)
                        )
                        (setq file (close file)) (_Open *file*)
                      )
                      (t
                        (if (eq "1" hastitle) (write-line mtitle file))

                        (setq maxL
                          (+ 7
                            (apply 'max
                              (mapcar
                                (function
                                  (lambda ( item ) (strlen (apply 'strcat item)))
                                )
                                (cons (list btitle ctitle) l)
                              )
                            )
                          )
                        )

                        (foreach line (cons (list btitle ctitle) l)
                          (write-line (_PadBetween (car line) (cadr line) " " maxL) file)
                        )
                        (setq file (close file)) (_Open *file*)
                      )
                    )
                    (princ "\n** Error Creating Output File **")
                  )
                  nil
                )
              )
            )
          )
        )
        (textscr)
      )
    )
    ( (princ "\n--> No Blocks Found.") )
  )
 
  (_WriteConfig cfgfname (mapcar 'eval SymList))
  (princ)
)

;............................................................;

(princ)
(princ "\n:: Count.lsp | Version 1.3 | © Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Type "Count" to Invoke ::")
(princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;

ProhibiT (06.02.2012 10:31 GMT)

06.02.2012 08:37    
@yQut
BU LİSP ÇALIŞMYOR GALİBA YÜKLEME SIRASINDA ERROR VERİYOR "Command: ; error: no function definition: VLAX-GET-ACAD-OBJECT

Command:
Command: blcksay
_GETSAVEPATH"

09.02.2012 11:53    
asencer
bende denedim bende çalıştıramadım.. haklısın.. sanırım kopyalayıp yapıstırırken bir hata oldu..
buraya tekrar kopyalıyorum. hata için özür dilerim.
Ehya bey yukarıdaki lisp i siler aşağıda vereceğim lispi güncellerse sorun çözülecektir.
saygılarımla.

;;---------------------=={ Incremental Numbering Suite }==---------------------;;
;; ;;
;; Incremental Numbering Suite enables the user to dynamically place ;;
;; incrementing alphabetical or numerical text in a drawing, with a range of ;;
;; positioning utilities and an optional prefix and/or suffix. ;;
;; ;;
;; The sequential text can be created using Text, MText or Attributed Blocks; ;;
;; furthermore, the style and formatting of these objects can be altered ;;
;; directly from the main dialog, with all settings remembered between drawing ;;
;; sessions. ;;
;; ;;
;; The user can modify the Text or Block layer, choose from a list of ;;
;; available Text Styles in the drawing, alter the Text or MText alignment, ;;
;; and change the Text Height or use the height defined by the selected ;;
;; Text Style. If MText is selected, the user may also toggle the use of an ;;
;; MText Background Mask. ;;
;; ;;
;; The user can enter optional Prefix, Middle and Suffix text, and have the ;;
;; option to increment either section, with the ability to increment ;;
;; alphabetical text and use decimals and leading zeros. The user can also ;;
;; specify any numerical increment, positive or negative. ;;
;; ;;
;; If the user has chosen to use Text or MText objects to house the ;;
;; incremental text, there is an option to enclose such objects with a border. ;;
;; The border may be Circular, Rectangular, Slot or an n-sided Polygon; ;;
;; created on a layer chosen from the main dialog. ;;
;; ;;
;; The size of the border may be controlled using an Offset from the Text or ;;
;; MText object; alternatively, the user may specify a fixed border size, with ;;
;; the option to pick either dimension from the drawing. ;;
;; ;;
;; Dynamic Mode ;;
;; -------------------------------------------- ;;
;; ;;
;; Dynamic Mode is activated by enabling the option: 'Text Follows Cursor'. ;;
;; ;;
;; This mode will display a real-time preview of the Text, MText or Attributed ;;
;; Block with any border that may be specified. ;;
;; ;;
;; Note: As a result of the method used to display the real-time preview, ;;
;; Dynamic Mode restricts the use of standard AutoCAD functionality such as ;;
;; Object Snap, Orthomode, Tracking etc. To enable such functionality, uncheck ;;
;; the 'Text Follows Cursor' option at the top-left corner of the dialog. ;;
;; ;;
;; Various positioning controls displayed at the command line: ;;
;; ;;
;; Dynamic Mode Placement Controls: ;;
;; -------------------------------------------- ;;
;; ;;
;; [ Enter ] - (or Space/Right-Click) Exit Program [Cancel] ;;
;; [ Click ] - Place Object ;;
;; [ < ] - Rotate Object Counter Clockwise ;;
;; [ > ] - Rotate Object Clockwise ;;
;; [ O ] - Specify Object Rotation ;;
;; [ Tab ] - Rotate Object by 90º ;;
;; [ M ] - Mirror Object Rotation ;;
;; [ C ] - Align Object to Curve ;;
;; [ R ] - Replace Existing Text/Attribute String ;;
;; [ T ] - Toggle Counter Increment ;;
;; [ B ] - Rotate Polygonal Border ;;
;; [ A ] - Toggle MText Background Mask ;;
;; ;;
;; Align Object to Curve ;;
;; -------------------------------------------- ;;
;; ;;
;; The user can choose to align the object to a selected curve object ;;
;; (Line, LWPolyline, Polyline, XLine, Spline, Arc, Circle, Ellipse etc.) by ;;
;; pressing C or c during placement. ;;
;; ;;
;; The user is then prompted to select a curve to which the text will be ;;
;; aligned. The text will follow the selected curve with various positioning ;;
;; controls available at the command-line: ;;
;; ;;
;; Curve Alignment Controls ;;
;; -------------------------------------------- ;;
;; ;;
;; [ Enter ] - (or Space/Right-Click) Exit Curve Alignment [Cancel] ;;
;; [ Click ] - Place Object ;;
;; [ +/- ] - Increase/Decrease Object Offset ;;
;; [ O ] - Specify Object Offset ;;
;; [ P ] - Toggle Object Perpendicularity ;;
;; [ B ] - Rotate Polygonal Border ;;
;; [ A ] - Toggle MText Background Mask ;;
;; ;;
;; Replace Existing Text or Attribute String ;;
;; -------------------------------------------- ;;
;; ;;
;; Upon pressing R or r during placement, the user is continuously prompted to ;;
;; select either Text, MText or Attribute, which, upon selection will be ;;
;; modified to contain the sequential text string. ;;
;; ;;
;; The user can exit this mode and return to standard text placement by ;;
;; pressing Enter, Space, or by Right-clicking the mouse at the prompt. ;;
;; ;;
;; Standard Placement Mode ;;
;; -------------------------------------------- ;;
;; ;;
;; This mode is available when the 'Text Follows Cursor' is disabled ;;
;; (unticked). ;;
;; ;;
;; When using this mode, there is no longer a real-time preview of the text at ;;
;; the cursor, however all standard AutoCAD functionality is available, ;;
;; (such as Object Snap, Tracking, Orthomode, etc.). ;;
;; ;;
;; The majority of placement controls are still available at the command-line: ;;
;; ;;
;; Non-Dynamic Mode Placement Controls: ;;
;; -------------------------------------------- ;;
;; ;;
;; [ Enter ] - (or Space/Right-Click) Exit Program [Cancel] ;;
;; [ Click ] - Place Object ;;
;; [ O ] - Specify Object Rotation ;;
;; [ RO ] - Rotate Object by 90º ;;
;; [ M ] - Mirror Object Rotation ;;
;; [ C ] - Align Object to Curve ;;
;; [ R ] - Replace Existing Text/Attribute String ;;
;; [ T ] - Toggle Counter Increment ;;
;; [ B ] - Rotate Polygonal Border ;;
;; [ A ] - Toggle MText Background Mask ;;
;; ;;
;;-------------------------------------------------------------------------------;;
;; ;;
;; FUNCTION SYNTAX: NumInc ;;
;; ;;
;;-------------------------------------------------------------------------------;;
;; ;;
;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;;
;; ;;
;;-------------------------------------------------------------------------------;;
;; Version: ;;
;; ;;
;; 1.0: 12/04/2009 - First Release. ;;
;;-------------------------------------------------------------------------------;;
;; 1.1: 14/04/2009 - Added Prefix/Suffix Option. ;;
;;-------------------------------------------------------------------------------;;
;; 1.2: 15/04/2009 - Added Dialog. ;;
;;-------------------------------------------------------------------------------;;
;; 1.3: 15/04/2009 - Added Option to Replace Existing text/attribute string. ;;
;;-------------------------------------------------------------------------------;;
;; 1.4: 18/04/2009 - Made program compatible with leading zeros. ;;
;;-------------------------------------------------------------------------------;;
;; 1.5: 16/06/2009 - Upgraded program code. ;;
;;-------------------------------------------------------------------------------;;
;; 1.6: 27/06/2009 - Added Counter Toggle. ;;
;; - General Bug Fixes. ;;
;;-------------------------------------------------------------------------------;;
;; 1.7: 18/02/2010 - General Program Upgrade. ;;
;;-------------------------------------------------------------------------------;;
;; 1.8: 19/02/2010 - Change Rotation Controls. ;;
;;-------------------------------------------------------------------------------;;
;; 1.9: 22/02/2010 - Added option to not use GrRead loop, and hence allow ;;
;; OSnap to function. ;;
;; - Added ability to place text in Table Cells. ;;
;;-------------------------------------------------------------------------------;;
;; 2.0: 24/02/2010 - Fixed Text Height Bug. ;;
;;-------------------------------------------------------------------------------;;
;; 2.1: 05/05/2010 - Removed imitation OSnap. ;;
;; - Modified loop to allow multiple replacements when in ;;
;; standard mode. ;;
;; - Added ability to use Alphabetical Increment. ;;
;;-------------------------------------------------------------------------------;;
;; 2.2: 06/05/2010 - Fixed bug with text case when incrementing alphabetical ;;
;; strings. ;;
;; - Added ability to border text with either Circle, ;;
;; Rectangle or Slot; and offset from text. ;;
;;-------------------------------------------------------------------------------;;
;; 2.3: 07/05/2010 - Changed the way that layer/style globals are stored to ;;
;; allow for layer/style changes between uses. ;;
;; - Removed Xref layers/styles from list. ;;
;; - Fixed UCS bugs. ;;
;;-------------------------------------------------------------------------------;;
;; 2.4: 10/05/2010 - Added a 'By Style' option for text height selection. ;;
;; - Added option to enclose text with n-sided Polygon. ;;
;; - Added ability to rotate polygonal border. ;;
;;-------------------------------------------------------------------------------;;
;; 2.5: 11/05/2010 - Allowed for Zero height in TextStyle. ;;
;; - Added ability to fix border size. ;;
;; - Fixed Text Height variable bug. ;;
;; - Fixed Rotation of odd-sided polygons. ;;
;;-------------------------------------------------------------------------------;;
;; 2.6: 12/05/2010 - Fixed Rotation of odd-sided polygons when text is not ;;
;; set to follow cursor. ;;
;; - Fixed Slot Bulges. ;;
;; - Added 'B' control to DCL About page. ;;
;;-------------------------------------------------------------------------------;;
;; 2.7: 22/05/2010 - Fixed Border issue when in different view. ;;
;;-------------------------------------------------------------------------------;;
;; 2.8: 24/05/2010 - Changed DCL/CFG file save path to make program ;;
;; compatible with Bricscad. ;;
;;-------------------------------------------------------------------------------;;
;; 2.9: 29/05/2010 - Upgraded code to determine DCL/CFG Filepath, to allow ;;
;; for AutoCAD Versions pre 2004. ;;
;;-------------------------------------------------------------------------------;;
;; 3.0: 10/10/2011 - Program completely rewritten to improve program ;;
;; performance, update code formatting and include the ;;
;; following new features: ;;
;; - Ability to use Text, MText or an Attributed Block to ;;
;; house incrementing string. ;;
;; - Ability to change Text / MText Alignment. ;;
;; - Ability to toggle the use of a Background Mask with ;;
;; MText. ;;
;; - Ability to specify both dimensions for the fixed size ;;
;; Slot / Rectangular border. ;;
;; - Vastly improved alphabetical text incrementing. ;;
;; - Improved handling of negative numbers. ;;
;; - Dialog interface completely redesigned to make it more ;;
;; user-friendly and intuitive to navigate. ;;
;; - Improved non-dynamic mode interface & functionality ;;
;; - Program works in all UCS/Views correctly. ;;
;;-------------------------------------------------------------------------------;;
;; 3.1: 11/10/2011 - Fixed bug concerning null text size variable when ;;
;; object is set to attributed block. ;;
;;-------------------------------------------------------------------------------;;

(setq NumIncVersion "3.1")

;;-------------------------------------------------------------------------------;;

(defun c:NumInc

(
/
*error*
_alignment
_attachment
_blocks
_layers
_styles
acdoc
acspc
alignment
alpha
att-nme
attachment
attrib
attribs
blk-nme
block
blocks
bor
bor-enc
bor-enc-fun
bor-lay
bor-rot
bor-shp
bor-shp-fun
bor-sid
bor-sid#
bor-typ
bor-typ-fun
cfgfname
create-bor
create-obj
dclflag
dclfname
dclid
dcltitle
deg
dyn-flg
elst
ent
file
fix-ed1
fix-ed1#
fix-ed2
fix-ed2#
g1
g2
gr
i
inc-sec
inc-str
mid-str
msg
mtx-bak
nm
obj
obj-typ
obj-typ-fun
off-ed1
off-ed1#
p1
p2
pre-str
prop
pt
savepath
ss
string
style
suf-str
symb
symlist
table
tile
tmp
tog-cnt
txt-aln
txt-bst
txt-lay
txt-rot
txt-sty
txt-sty-fun
txt-sze
txt-sze#
vallst
varlst
xa
)

(defun *error* ( msg )
(if (eq "1" dyn-flg)
(progn
(if (and obj (not (vlax-erased-p obj))) (vla-delete obj))
(if (and bor (not (vlax-erased-p bor))) (vla-delete bor))
)
)
(if vallst (mapcar 'setvar varlst vallst))
(if (and file (eq 'FILE (type file))) (setq file (close file)))
(if (< 0 dclID) (setq dclID (unload_dialog dclID)))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(setq varlst '("DIMZIN" "MODEMACRO")
vallst (mapcar 'getvar varlst)
)

(cond
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
(princ "\nCurrent Layer Locked.")
)
( (not (vl-file-directory-p (setq savepath (NumInc:GetSavePath))))
(NumInc:Popup "Warning" 16 "Save Path not Valid.")
(princ "\nSave Path not Valid.")
)
( (progn
(setq dclfname (strcat savepath "\\LMAC_NumInc_V" (vl-string-translate "." "-" NumIncVersion) ".dcl")
cfgfname (strcat savepath "\\LMAC_NumInc_V" (vl-string-translate "." "-" NumIncVersion) ".cfg")
dcltitle (strcat "Incremental Numbering Suite V" NumIncversion)
)
(not (NumInc:WriteDCL dclfname))
)
(NumInc:Popup "Warning" 16 "DCL File could not be Written.")
(princ "\nDCL File could not be Written.")
)
( (<= (setq dclID (load_dialog dclfname)) 0)
(NumInc:Popup "Warning" 16 "The DCL File could not be Loaded.")
(princ "\nThe DCL File could not be Loaded.")
)
( t
(setq SymList
(list
(cons 'crv-per (/ pi 2.0))
(cons 'crv-off 0.0)
(cons 'mtx-bak :vlax-false)
(cons 'txt-rot 0.0)
(cons 'bor-rot nil)
(cons 'tog-cnt t)
(cons 'dyn-flg "1")
(cons 'pre-str "")
(cons 'mid-str "1")
(cons 'suf-str "")
(cons 'inc-str "1")
(cons 'inc-sec "inc-mid")
(cons 'obj-typ "obj-txt")
(cons 'blk-nme "")
(cons 'att-nme "")
(cons 'bor-enc "0")
(cons 'bor-shp "0")
(cons 'bor-sid "6")
(cons 'bor-lay (getvar 'CLAYER))
(cons 'bor-typ "bor-off")
(cons 'off-ed1 "1.0")
(cons 'fix-ed1 "1.0")
(cons 'fix-ed2 "1.0")
(cons 'txt-lay (getvar 'CLAYER))
(cons 'txt-sty (getvar 'TEXTSTYLE))
(cons 'txt-aln "Middle-Center")
(cons 'txt-bst "1")
(cons 'txt-sze
(rtos
(if
(zerop
(cdr
(assoc 40
(setq style
(tblsearch "STYLE" (getvar 'TEXTSTYLE))
)
)
)
)
(cdr (assoc 42 style))
(cdr (assoc 40 style))
)
)
)
)
)
(if (null (findfile cfgfname))
(NumInc:WriteConfig cfgfname (mapcar 'cdr SymList))
)
(NumInc:ReadConfig cfgfname (mapcar 'car SymList))
(foreach x SymList
(if (null (boundp (car x)))
(set (car x) (cdr x))
)
)

(setq _layers (NumInc:GetTableItems "LAYER")
_styles (NumInc:GetTableItems "STYLE")
_blocks (NumInc:GetBlockData)
)

(setq Alignment
(list
(cons "Left" acAlignmentLeft)
(cons "Center" acAlignmentCenter)
(cons "Right" acAlignmentRight)
(cons "Middle" acAlignmentMiddle)
(cons "Top-Left" acAlignmentTopLeft)
(cons "Top-Center" acAlignmentTopCenter)
(cons "Top-Right" acAlignmentTopRight)
(cons "Middle-Left" acAlignmentMiddleLeft)
(cons "Middle-Center" acAlignmentMiddleCenter)
(cons "Middle-Right" acAlignmentMiddleRight)
(cons "Bottom-Left" acAlignmentBottomLeft)
(cons "Bottom-Center" acAlignmentBottomCenter)
(cons "Bottom-Right" acAlignmentBottomRight)
)
)

(setq Attachment
(list
(cons "Top-Left" acAttachmentPointTopLeft)
(cons "Top-Center" acAttachmentPointTopCenter)
(cons "Top-Right" acAttachmentPointTopRight)
(cons "Middle-Left" acAttachmentPointMiddleLeft)
(cons "Middle-Center" acAttachmentPointMiddleCenter)
(cons "Middle-Right" acAttachmentPointMiddleRight)
(cons "Bottom-Left" acAttachmentPointBottomLeft)
(cons "Bottom-Center" acAttachmentPointBottomCenter)
(cons "Bottom-Right" acAttachmentPointBottomRight)
)
)

(setq _Alignment (mapcar 'car Alignment))
(setq _Attachment (mapcar 'car Attachment))

(while (not (member dclflag '(1 0)))
(cond
( (not (new_dialog "numinc" dclID))
(NumInc:Popup "Warning" 16 "Dialog could not be Loaded.")
(princ "\nDialog could not be Loaded.")
)
( t

;;-------------------------------------------------------------------------------;;
;; Top of Dialog ;;
;;-------------------------------------------------------------------------------;;

(set_tile "dcltitle" dcltitle)

(set_tile "dyn-flg" dyn-flg)
(action_tile "dyn-flg" "(setq dyn-flg $value)")

;;-------------------------------------------------------------------------------;;
;; Top-Left Panel ;;
;;-------------------------------------------------------------------------------;;

(foreach symb '(pre-str mid-str suf-str inc-str)
(setq tile (strcase (vl-symbol-name symb) t))
(set_tile tile (eval symb))
(action_tile tile (strcat "(setq " tile " $value)"))
)

(set_tile inc-sec "1")
(action_tile "inc-pre" "(setq inc-sec $key)")
(action_tile "inc-mid" "(setq inc-sec $key)")
(action_tile "inc-suf" "(setq inc-sec $key)")

;;-------------------------------------------------------------------------------;;
;; Bottom-Right Panel ;;
;;-------------------------------------------------------------------------------;;

(NumInc:MakeList "txt-lay" _layers)

(set_tile "txt-lay"
(itoa
(cond
( (vl-position txt-lay _layers))
( (vl-position (setq txt-lay (getvar 'CLAYER)) _layers))
)
)
)
(action_tile "txt-lay" "(setq txt-lay (nth (atoi $value) _layers))")

;;-------------------------------------------------------------------------------;;

(NumInc:MakeList "txt-sty" _styles)

(set_tile "txt-sty"
(itoa
(cond
( (vl-position txt-sty _styles))
( (vl-position (setq txt-sty (getvar 'TEXTSTYLE)) _styles))
)
)
)
(
(setq txt-sty-fun
(lambda ( style / tmp )
(if (zerop (setq tmp (cdr (assoc 40 (tblsearch "STYLE" style)))))
(progn
(set_tile "txt-bst" (setq txt-bst "0"))
(mode_tile "txt-bst" 1)
(mode_tile "txt-sze" 0)
)
(progn
(mode_tile "txt-bst" 0)
(if (eq "1" txt-bst)
(set_tile "txt-sze" (setq txt-sze (rtos tmp)))
)
)
)
)
)
txt-sty
)
(action_tile "txt-sty" "(txt-sty-fun (setq txt-sty (nth (atoi $value) _styles)))")

;;-------------------------------------------------------------------------------;;

(NumInc:MakeList "txt-aln" (if (eq "obj-mtx" obj-typ) _Attachment _Alignment))

(set_tile "txt-aln"
(itoa
(vl-position txt-aln
(if (eq "obj-mtx" obj-typ) _Attachment _Alignment)
)
)
)

(action_tile "txt-aln"
(vl-prin1-to-string
(quote
(setq txt-aln
(nth (atoi $value) (if (eq "obj-mtx" obj-typ) _Attachment _Alignment))
)
)
)
)

;;-------------------------------------------------------------------------------;;

(set_tile "txt-sze" txt-sze)
(action_tile "txt-sze" "(setq txt-sze $value)")

(if (eq "1" txt-bst)
(if (zerop (setq tmp (cdr (assoc 40 (tblsearch "STYLE" txt-sty)))))
(progn
(set_tile "txt-bst" (setq txt-bst "0"))
(mode_tile "txt-bst" 1)
(mode_tile "txt-sze" 0)
)
(progn
(set_tile "txt-bst" txt-bst)
(set_tile "txt-sze" (setq txt-sze (rtos tmp)))
)
)
)
(mode_tile "txt-sze" (atoi txt-bst))

(action_tile "txt-bst"
(vl-prin1-to-string
(quote
(progn
(mode_tile "txt-sze" (atoi (setq txt-bst $value)))
(if (eq "1" $value)
(set_tile "txt-sze" (rtos (cdr (assoc 40 (tblsearch "STYLE" txt-sty)))))
)
)
)
)
)

;;-------------------------------------------------------------------------------;;
;; Bottom-Left Panel ;;
;;-------------------------------------------------------------------------------;;

(set_tile "bor-enc" bor-enc)
(
(setq bor-enc-fun
(lambda ( value )
(if (eq "1" value)
(progn
(mode_tile "bor-shp" 0)
(if (eq "3" bor-shp) (mode_tile "bor-sid" 0))
(mode_tile "bor-lay" 0)
(mode_tile "bor-off" 0)
(mode_tile "bor-fix" 0)
(mode_tile "bor-pik" 0)
(mode_tile "bor-ltx" 0)
(if (eq "bor-off" bor-typ)
(progn
(mode_tile "off-ed1" 0)
(mode_tile "fix-ed1" 1)
(mode_tile "fix-txt" 1)
(mode_tile "fix-ed2" 1)
)
(progn
(mode_tile "off-ed1" 1)
(mode_tile "fix-ed1" 0)
(if (member bor-shp '("1" "2"))
(progn
(mode_tile "fix-txt" 0)
(mode_tile "fix-ed2" 0)
)
(progn
(mode_tile "fix-txt" 1)
(mode_tile "fix-ed2" 1)
)
)
)
)
)
(foreach tile
'(
"bor-shp" "bor-sid" "bor-lay"
"bor-off" "bor-fix" "off-ed1"
"fix-ed1" "fix-ed2" "bor-pik"
"fix-txt" "bor-ltx"
)
(mode_tile tile 1)
)
)
)
)
bor-enc
)
(action_tile "bor-enc" "(bor-enc-fun (setq bor-enc $value))")

;;-------------------------------------------------------------------------------;;

(NumInc:MakeList "bor-shp" '("Circle" "Rectangle" "Slot" "Polygon"))

(set_tile "bor-shp" bor-shp)
(
(setq bor-shp-fun
(lambda ( value )
(if (eq "bor-fix" bor-typ)
(mapcar 'mode_tile '("bor-sid" "fix-txt" "fix-ed2")
(cond
( (eq value "0")
'(1 1 1)
)
( (member value '("1" "2"))
'(1 0 0)
)
( '(0 1 1)
)
)
)
(mapcar 'mode_tile '("bor-sid" "fix-txt" "fix-ed2")
(cond
( (member value '("0" "1" "2"))
'(1 1 1)
)
( '(0 1 1)
)
)
)
)
)
)
bor-shp
)
(action_tile "bor-shp" "(bor-shp-fun (setq bor-shp $value))")

;;-------------------------------------------------------------------------------;;

(set_tile "bor-sid" bor-sid)
(action_tile "bor-sid" "(setq bor-sid $value)")

;;-------------------------------------------------------------------------------;;

(NumInc:MakeList "bor-lay" _layers)

(set_tile "bor-lay"
(itoa
(cond
( (vl-position bor-lay _layers))
( (vl-position (setq bor-lay (getvar 'CLAYER)) _layers))
)
)
)
(action_tile "bor-lay" "(setq bor-lay (nth (atoi $value) _layers))")

;;-------------------------------------------------------------------------------;;

(set_tile bor-typ "1")
(
(setq bor-typ-fun
(lambda ( typ )
(if (eq "1" bor-enc)
(if (eq "bor-off" typ)
(mapcar 'mode_tile '("off-ed1" "fix-ed1" "fix-ed2" "fix-txt") '(0 1 1 1))
(progn
(mode_tile "off-ed1" 1)
(mode_tile "fix-ed1" 0)
(if (member bor-shp '("1" "2"))
(progn
(mode_tile "fix-ed2" 0)
(mode_tile "fix-txt" 0)
)
)
)
)
)
)
)
bor-typ
)
(action_tile "bor-off" "(bor-typ-fun (setq bor-typ $key))")
(action_tile "bor-fix" "(bor-typ-fun (setq bor-typ $key))")

;;-------------------------------------------------------------------------------;;

(foreach symb '(off-ed1 fix-ed1 fix-ed2)
(setq tile (strcase (vl-symbol-name symb) t))
(set_tile tile (eval symb))
(action_tile tile (strcat "(setq " tile " $value)"))
)

(action_tile "bor-pik" "(done_dialog 3)")

;;-------------------------------------------------------------------------------;;
;; Top-Right Panel ;;
;;-------------------------------------------------------------------------------;;

(set_tile obj-typ "1")

(
(setq obj-typ-fun
(lambda ( typ )
(if (eq typ "obj-blk")
(progn
(set_tile "lay-txt" "Block Layer: ")
(foreach pair
'(
("blk-nme" 0)
("blk-txt" 0)
("blk-pik" 0)
("att-txt" 0)
("att-nme" 0)
("sty-txt" 1)
("txt-sty" 1)
("aln-txt" 1)
("txt-aln" 1)
("txt-bst" 1)
("txt-sze" 1)
("bor-enc" 1)
("bor-shp" 1)
("bor-sid" 1)
("bor-ltx" 1)
("bor-lay" 1)
("bor-off" 1)
("bor-fix" 1)
("off-ed1" 1)
("fix-ed1" 1)
("fix-ed2" 1)
("bor-pik" 1)
)
(apply 'mode_tile pair)
)
)
(progn
(set_tile "lay-txt" "Text Layer: ")
(foreach pair
'(
("blk-txt" 1)
("blk-nme" 1)
("blk-pik" 1)
("att-txt" 1)
("att-nme" 1)
("sty-txt" 0)
("txt-sty" 0)
("aln-txt" 0)
("txt-aln" 0)
("bor-enc" 0)
)
(apply 'mode_tile pair)
)
(bor-enc-fun bor-enc)
(txt-sty-fun txt-sty)
(NumInc:MakeList "txt-aln" (if (eq "obj-mtx" obj-typ) _Attachment _Alignment))
(set_tile "txt-aln"
(itoa
(vl-position txt-aln
(if (eq "obj-mtx" obj-typ) _Attachment _Alignment)
)
)
)
)
)
)
)
obj-typ
)

(action_tile "obj-txt" "(obj-typ-fun (setq obj-typ $key))")
(action_tile "obj-mtx" "(obj-typ-fun (setq obj-typ $key))")
(action_tile "obj-blk" "(obj-typ-fun (setq obj-typ $key))")

(if _blocks
(progn
(NumInc:MakeList "blk-nme" (setq blocks (mapcar 'car _blocks)))
(set_tile "blk-nme"
(setq block
(itoa
(cond
( (vl-position blk-nme blocks))
( (setq blk-nme (car blocks))
0
)
)
)
)
)
(NumInc:MakeList "att-nme" (setq attribs (cdr (nth (atoi block) _blocks))))
(set_tile "att-nme"
(setq attrib
(itoa
(cond
( (vl-position att-nme attribs))
( (setq att-nme (car attribs))
0
)
)
)
)
)
)
(foreach tile '("obj-blk" "blk-nme" "att-nme" "blk-pik")
(mode_tile tile 1)
)
)

(action_tile "blk-nme"
(vl-prin1-to-string
(quote
(progn
(setq blk-itm (nth (atoi (setq block $value)) _blocks)
blk-nme (car blk-itm)
)
(NumInc:MakeList "att-nme" (setq attribs (cdr blk-itm)))
(set_tile "att-nme"
(setq attrib
(itoa
(cond
( (vl-position att-nme attribs))
( (setq att-nme (car attribs))
0
)
)
)
)
)
)
)
)
)

(action_tile "blk-pik" "(done_dialog 2)")
(action_tile "att-nme" "(setq attrib $value att-nme (nth (atoi $value) attribs))")

;;-------------------------------------------------------------------------------;;
;; Base of Dialog ;;
;;-------------------------------------------------------------------------------;;

(action_tile "about" "(NumInc:About dclID)")

(action_tile "accept"
(vl-prin1-to-string
(quote
(progn
(if (eq "" inc-str) (setq inc-str "0"))
(if (eq "" txt-sze) (setq txt-sze (rtos (getvar 'TEXTSIZE))))

(setq alpha
(or
(and (eq "inc-pre" inc-sec) (not (distof pre-str 2)))
(and (eq "inc-mid" inc-sec) (not (distof mid-str 2)))
(and (eq "inc-suf" inc-sec) (not (distof suf-str 2)))
)
)
(cond
( (and
(eq "1" bor-enc)
(eq "bor-off" bor-typ)
(not (setq off-ed1# (distof off-ed1)))
)
(NumInc:Popup "Information" 48 "Border Offset must be numerical.")
(mode_tile "off-ed1" 2)
)
( (and
(eq "1" bor-enc)
(eq "bor-off" bor-typ)
(< off-ed1# 0.0)
)
(NumInc:Popup "Information" 48 "Border Offset must be greater than zero.")
(mode_tile "off-ed1" 2)
)
( (and
(eq "1" bor-enc)
(eq "bor-fix" bor-typ)
(or
(not (setq fix-ed1# (distof fix-ed1)))
(and
(member bor-shp '("1" "2"))
(not (setq fix-ed2# (distof fix-ed2)))
)
)
)
(NumInc:Popup "Information" 48 "Border Size must be numerical.")
(mode_tile "fix-ed1" 2)
)
( (and
(eq "1" bor-enc)
(eq "bor-fix" bor-typ)
(or
(<= fix-ed1# 0.0)
(and
(member bor-shp '("1" "2"))
(<= fix-ed2# 0.0)
)
)
)
(NumInc:Popup "Information" 48 "Border Size must be greater than zero.")
(mode_tile "fix-ed1" 2)
)
( (not (distof inc-str 2))
(NumInc:Popup "Information" 48 "Increment not numerical.")
(mode_tile "inc-str" 2)
)
( (and
(not (eq "obj-blk" obj-typ))
(not (setq txt-sze# (distof txt-sze)))
)
(NumInc:Popup "Information" 48 "Text Height not numerical.")
(if (eq "0" txt-bst)
(mode_tile "txt-sze" 2)
)
)
( (and
(not (eq "obj-blk" obj-typ))
(<= txt-sze# 0.0)
)
(NumInc:Popup "Information" 48 "Text Height must be greater than zero.")
(if (eq "0" txt-bst)
(mode_tile "txt-sze" 2)
)
)
( (and
(eq "1" bor-enc)
(eq "3" bor-shp)
(< (setq bor-sid# (atoi bor-sid)) 3)
)
(NumInc:Popup "Information" 48 "Number of Polygon Sides must be numerical\nand greater than 2.")
(mode_tile "bor-sid" 2)
)
( t
(done_dialog 1)
)
)
)
)
)
)

(setq dclflag (start_dialog))
)
)
(cond
( (= 2 dclflag)
(while
(progn (setvar 'ERRNO 0) (setq ent (car (entsel "\nSelect Block: ")))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'ENAME (type ent))
(if
(and
(eq "INSERT" (cdr (assoc 0 (setq elst (entget ent)))))
(= 1 (cdr (assoc 66 elst)))
)
(progn
(setq blk-nme
(if (vlax-property-available-p (setq obj (vlax-ename->vla-object ent)) 'effectivename)
(vla-get-effectivename obj)
(vla-get-name obj)
)
)
nil
)
(princ "\nPlease select a Block.")
)
)
)
)
)
)
( (= 3 dclflag)
(cond
( (eq "bor-off" bor-typ)
(setq off-ed1
(cond
( (setq tmp
(getdist
(strcat "\nSpecify Offset <" off-ed1 ">: ")
)
)
(rtos tmp)
)
( off-ed1 )
)
)
)
( t
(cond
( (member bor-shp '("0" "3"))
(setq fix-ed1
(cond
( (setq tmp
(getdist
(strcat "\nSpecify Border Radius <" fix-ed1 ">: ")
)
)
(rtos tmp)
)
( fix-ed1 )
)
)
)
( t
(if
(and
(setq p1 (getpoint "\nSpecify First Point: "))
(setq p2 (getcorner p1 "\nSpecify Opposite Corner: "))
)
(setq fix-ed1 (rtos (abs (- (car p2) (car p1))))
fix-ed2 (rtos (abs (- (cadr p2) (cadr p1))))
)
)
)
)
)
)
)
)
)
(if (= 1 dclflag)
(progn
(if
(setq ss
(ssget "_X"
(list '(0 . "ACAD_TABLE")
(cons 410
(if (= 1 (getvar 'CVPORT))
(getvar 'CTAB)
"Model"
)
)
)
)
)
(repeat (setq i (sslength ss))
(setq table (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) table))
)
)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'paperspace 'modelspace))
)
(setq nm (trans '(0.0 0.0 1.0) 1 0 t)
xa (angle '(0.0 0.0 0.0) (trans (getvar 'UCSXDIR) 0 nm t))
)
(if (and (not (eq "obj-blk" obj-typ)) (NumInc:isAnnotative txt-sty))
(setq txt-sze# (/ txt-sze# (cond ((getvar 'CANNOSCALEVALUE)) (1.0))))
)
(setq symb
(nth
(vl-position inc-sec '("inc-pre" "inc-mid" "inc-suf"))
'(pre-str mid-str suf-str)
)
)

(setq prop
(if
(and
(eq "obj-txt" obj-typ)
(not (eq "Left" txt-aln))
)
'TextAlignmentPoint
'InsertionPoint
)
)

(setq create-obj
(cond
( (eq "obj-txt" obj-typ)
(lambda ( point string / obj )
(setq point (vlax-3D-point (trans point 1 0))
obj (vla-addtext acspc string point txt-sze#)
)
(vla-put-stylename obj txt-sty)
(vla-put-layer obj txt-lay)
(vla-put-alignment obj (cdr (assoc txt-aln Alignment)))
(if (eq "Left" txt-aln)
(vla-put-insertionpoint obj point)
(vla-put-textalignmentpoint obj point)
)
(vla-put-rotation obj (+ xa txt-rot))
obj
)
)
( (eq "obj-mtx" obj-typ)
(lambda ( point string / obj )
(setq point (vlax-3D-point (trans point 1 0)))
(setq obj
(vla-addmtext acspc point
(
(lambda ( box ) (- (caadr box) (caar box)))
(textbox
(list
(cons 1 (strcat string "A"))
(cons 40 txt-sze#)
(cons 7 txt-sty)
)
)
)
string
)
)
(vla-put-stylename obj txt-sty)
(vla-put-layer obj txt-lay)
(vla-put-height o

21.09.2015 08:48    
erdibaskan
herhangi bir lisp e gerek duymadan quick select ile bu işlemi yapabilirsin

command'a qselect yaz object type block sec properties kısmından name sec value kısmında ciziminde bulunan blokların isimleri gelir oradan sayısını öğrenmek istediğin block ismini sec okeyle command satırında kaç adet blok seçtiği yazacaktır.

ayrıca bu işlemi çiziminde bulunan bütün objeler içinde kullanabilirsin.

admin (29.05.2018 21:51 GMT)

> 1 <
Copyright © 2004-2022 SQL: 1.294 saniye - Sorgu: 70 - Ortalama: 0.01848 saniye