Lisp Перенос текста в таблицу

;; exhausted by fixo
(defun C:journal (/ col en grkw next pick row stxt tbl txt vec  xdir ydir zdir)
 
;; local function by gile
(defun CrossProduct (v1 v2)
  (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
    (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
    (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)
  
  ;;  -------------------   main part   ---------------------;;
  (princ "\nSelect a table:")
  (while (not tbl)
    (if    (setq en (entsel "\n   ---   Select a table:   ---"))
      (progn
    (setq tbl (vlax-ename->vla-object (car en)))
    (if (not (eq "AcDbTable" (vla-get-ObjectName tbl)))
      (progn
        (princ "Object selected is not a table.")
        (setq tbl nil)
      )
    )
      )
      (princ "Nothing selected.")
    )
  )
  
  (initget "Row Column")
  (setq grkw (getint
         (strcat
           "\nChoose filling mode by [Row/Column]: <Row>"
          )
           )
      )
       (if (not grkw)
     
    (setq  grkw "Row");;<-- in this case get default value
      )

         (setq pick (getpoint "\nPick inside the starting cell: "))  
             (setq xdir    (getvar "ucsxdir")
               ydir    (getvar "ucsydir")
               zdir    (CrossProduct xdir ydir))


             (setq vec (vlax-make-variant
                 (vlax-safearray-fill
                   (vlax-make-safearray vlax-vbDouble '(0 . 2))
                   zdir))
               );<-- equal to :(setq vec (vlax-3d-point zdir))
  (if (eq :vlax-true
                 (vla-hittest
                   tbl
                   (vlax-3d-point (trans pick 1 0))
                   vec
                   'row
                   'col));<-- by reference

               (vla-setsubselection tbl row row col col);<--highlight picked cell

               )
  (if (eq "Row" grkw)(progn
  (princ "\n   ---   Select a text/mtext one by one:   ---")
  (setq next T)
  (while (and next (setq stxt (ssget "+.:S:E:L" (list (cons 0 "*text")))))
    (setq txt (cdr (assoc 1 (entget (ssname stxt 0)))))
   (if (not (vl-catch-all-error-p      
        (vl-catch-all-apply 'vla-settext (list tbl row col txt)))
      )

    (progn
    (vla-setsubselection tbl row row col col)
    (setq row (1+ row)))
     (progn
     (alert "End is reached")
     (setq next nil))))
  ))
  (if (eq "Column" grkw)(progn
  (princ "\n   ---   Select a text/mtext one by one:   ---")
  (setq next T)
  (while (and next (setq stxt (ssget "+.:S:E:L" (list (cons 0 "*text")))))
    (setq txt (cdr (assoc 1 (entget (ssname stxt 0)))))
   (if (not (vl-catch-all-error-p      
        (vl-catch-all-apply 'vla-settext (list tbl row col txt)))
      )

    (progn
    (vla-setsubselection tbl row row col col)
    (setq col (1+ col)))
     (progn
     (alert "End is reached")
     (setq next nil))))
  ))
  (vla-update tbl)
  (vlax-release-object tbl)
  (princ)
)
(prompt "\n   ---   Start command with \"JOURNAL\"   ---")
(prin1)
(vl-load-com)
(princ)

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

;; exhausted by fixo
;; edited 1/26/12   
(defun C:demo (/ cnt col data dirty en next pick row stxt tbl txt vec  xdir ydir zdir)
 
;; local function by gile
(defun CrossProduct (v1 v2)
  (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
    (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
    (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)
  
  ;;  -------------------   main part   ---------------------;;

  (while (not tbl)
    (if    (setq en (entsel "\nВыбрать таблицу:"))
      (progn
    (setq tbl (vlax-ename->vla-object (car en)))
    (if (not (eq "AcDbTable" (vla-get-ObjectName tbl)))
      (progn
        (princ "Выбранный объект не таблица.")
        (setq tbl nil)
      )
    )
      )
      (princ "Ничего не выбрано.")
    )
  )


         (setq pick (getpoint "\nУказать точку внутри ячейки: "))  
             (setq xdir    (getvar "ucsxdir")
               ydir    (getvar "ucsydir")
               zdir    (CrossProduct xdir ydir))


             (setq vec (vlax-make-variant
                 (vlax-safearray-fill
                   (vlax-make-safearray vlax-vbDouble '(0 . 2))
                   zdir))
               )
  (if (eq :vlax-true
                 (vla-hittest
                   tbl
                   (vlax-3d-point (trans pick 1 0))
                   vec
                   'row
                   'col))

               (vla-setsubselection tbl row row col col)

               )

  (princ "\n   ---   Выбрать тексты по одному попарно:   ---")
  (setq next T)
  (while (and next (setq stxt (ssget "_:S" (list (cons 0 "*text")))))
    (setq txt (cdr (assoc 1 (entget (ssname stxt 0)))))
    (setq dirty (cons txt dirty))
    )
  (if (/= 0(rem (length dirty) 2))
    (progn
      (alert "Число выбранных текстов не кратно двум. Отбой...")
      (exit)
      (princ)
      )
    )
    (setq dirty (reverse dirty)
      data nil)
 
  (while (cadr dirty)
    (setq data (append (list (list (car dirty) (cadr dirty))) data))
    (setq dirty (cddr dirty))
  )
  
  (setq data (reverse data))
  
 (setq cnt col)
  
  (foreach item data
    (setq col cnt)
    (vl-catch-all-apply 'vla-settext (list tbl row col (car item)))
    
    (setq col (1+ col))
   (vl-catch-all-apply 'vla-settext (list tbl row col (cadr item)))
    
    (setq row (1+ row))
    )
   (vl-catch-all-apply 'vla-clearsubselection (list tbl))
  (vla-update tbl)
  (vlax-release-object tbl)
  (princ)
)
(prompt "\n   ---   команда на выполнение \"DEMO\"   ---")
(prin1)
(or (vl-load-com)
(princ)    )
;;---------------------------------------------------------;;