[miha]

Тексты из ACAD в Excel
Имеются «спецификации» в Акаде, (пространство-модель), состоящие из рамок (line), и текстов (буковки и цифирки-single line text). Как преобразовать это безобразие в Excel таблицу, учитывая, что в этих «спецификациях» есть пустые «ячейки»?
Прошу подсказать симпатичную прогу (лиспец и т.п.).

[Кулик Алексей aka kpblc]

http://uniip.ru/lib/download/files/l...t-to-excel.zip

[Лентяй]

Держи прогу. Преобразовывает КАДский текст в не менее КАДскую же таблицу, сиречь спецификациюю

Код:

[Выделить все]

(defun c:ttc (/ actDoc vlaObj sObj sText curObj oldForm oType oldMode conFlag errFlag *error*)
  (vl-load-com)
  (setq actDoc(vla-get-ActiveDocument (vlax-get-acad-object))
	util (vla-get-utility adoc))
  (vla-StartUndoMark actDoc)
;
(defun TTC_Paste (pasteStr / nslLst vlaObj hitPt hitRes Row Column)
  (setq errFlag nil)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
			(vla-getentity util 'vlaObj 'pt "\nPaste text >")))))
    (progn
      (cond ((= (vla-get-objectname vlaObj) "AcDbRotatedDimension")
	     (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextOverride (list vlaObj pasteStr)))
	       (progn (princ "\n Can't paste. Object may be on locked layer. ")
		      (setq errFlag T))));#1
	    ((= (vla-get-objectname vlaObj) "AcDbTable")
	     (setq hitRes (vla-HitTest vlaObj pt (vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Column));setq
	     (if (= :vlax-true hitRes)
	       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-SetText (list vlaObj Row Column pasteStr)))
		   (progn  (princ "\n Can't paste. Object may be on locked layer. ")
		     (setq errFlag T)))));# 2
	    ((= (vla-get-objectname vlaObj) "AcDbBlockReference")
	     (princ "\nCan't paste to block's DText or MText. ")
	     (setq errFlag T));#3
	    ((member (vla-get-objectname vlaObj) '("AcDbText" "AcDbMText" "AcDbAttrib" "AcDbAttDef"))
	     (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
	       (progn (princ "\nError. Can't pase text. ")
		      (setq errFlag T))));#4
	    (T (princ "\nCan't paste. Invalid object. ") (setq errFlag T));#5
      );cond
      T);progn
  nil);if
); end of TTC_Paste
;
(defun TTC_MText_Clear(Mtext / Text Str)
  (setq Text "")
  (while (/= Mtext "")
    (cond ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}`~]")
	   (setq Mtext (substr Mtext 3) Text (strcat Text Str)));#1
	  ((wcmatch (substr Mtext 1 1) "[{}]")
	   (setq Mtext (substr Mtext 2)));#2
	  ((and (wcmatch (strcase (substr Mtext 1 2)) "\\P")
		(/=(substr Mtext 3 1) " "));and
	   (setq Mtext (substr Mtext 3) Text (strcat Text " ")));#3
	  ((wcmatch (strcase (substr Mtext 1 2)) "\\[LOP]")
	   (setq Mtext (substr Mtext 3)));#4
	  ((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
	   (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))));#5
	  ((wcmatch (strcase (substr Mtext 1 2)) "\\S")
	   (setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
		 Text (strcat Text (vl-string-translate "#^\\" " " Str))
		 Mtext (substr Mtext (+ 4 (strlen Str))));setq
	   (print Str));#6
	  (T (setq Text (strcat Text(substr Mtext 1 1))
		   Mtext (substr Mtext 2)));#7
     );cond
  );while
  Text
);TTC_MText_Clear
;
(defun TTC_Copy (/ sObj sText)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()
		 (vla-getentity util 'sObj 'pt "\nCopy text >")))))
    (if (and sObj (member (vla-get-objectname sObj)
			'("AcDbText" "AcDbMText" "AcDbAttrib" "AcDbAttDef")));and
      (progn (setq sText (vla-get-TextString sObj));setq
	(if (= (vla-get-objectname sObj) "AcDbMText") (setq sText (TTC_MText_Clear sText)) sText)));if
  );if
);TTC_Copy
;
(defun CCT_Str_Echo(paseStr / comStr)
  (if (< 20(strlen paseStr))
    (setq comStr (strcat (substr paseStr 1 17)"..."))
    (setq comStr paseStr));if
  (princ (strcat "\nText = \"" comStr "\""))
  (princ)
);CCT_Str_Echo
;
(defun *error* (msg)
  (vla-EndUndoMark astdoc)
  (princ "\nQuit TTC")
  (princ)
); end of *error*
;
(if (not ttc:Mode) (setq ttc:Mode "Multiple"))
  (initget "Multiple Pair-wise")
  (setq oldMode ttc:Mode
	ttc:Mode (getkword (strcat "\nSpecify mode [Multiple/Pair-wise] <"ttc:Mode">: "))
	conFlag T paseStr "");setq
  (if (null ttc:Mode) (setq ttc:Mode oldMode))
  (if (= ttc:Mode "Multiple")
    (progn (if (and (setq paseStr (TTC_Copy)) conFlag);and
	     (progn (CCT_Str_Echo paseStr)
	       (while (setq conFlag (TTC_Paste paseStr)) T))));progn
    (progn (while (and conFlag paseStr)
	     (setq paseStr (TTC_Copy))
	     (if (and paseStr conFlag)
	       (progn (CCT_Str_Echo paseStr) (setq errFlag T)
		 (while errFlag (setq conFlag (TTC_Paste paseStr))))))));if
  (vla-EndUndoMark actDoc)
  (princ "\nQuit TTC")
  (princ)
); end c:ttc

[ASLYS]

2Лентяй
у меня не работает (2008 eng)

Command: (LOAD "C:/alex/A-cad/lisp/TTC.lsp") C:TTC

Command: TTC
; error: bad argument type: VLA-OBJECT nil

Command:

[miha]

Спасибо!

[Tserber]

Сообщение от ASLYS 2Лентяй у меня не работает (2008 eng) Command: (LOAD "C:/alex/A-cad/lisp/TTC.lsp") C:TTC Command: TTC ; error: bad argument type: VLA-OBJECT nil Command:

у меня 2004 eng, а эффект тот же самый :cry:

[Кулик Алексей aka kpblc]

А так сработает?

Код:

[Выделить все]

(defun c:ttc (/         actdoc    vlaobj    sobj      stext     curobj
              oldform   otype     oldmode   conflag   errflag   *error*
              )
  (vl-load-com)
  (setq actdoc (vla-get-activedocument (vlax-get-acad-object))
        util   (vla-get-utility actdoc)
        ) ;_ end of setq
  (vla-startundomark actdoc)
  (defun ttc_paste (pastestr / nsllst vlaobj hitpt hitres row column)
    (setq errflag nil)
    (if (not (vl-catch-all-error-p
               (vl-catch-all-apply
                 '(lambda ()
                    (vla-getentity util 'vlaobj 'pt "\nPaste text >")
                    ) ;_ end of lambda
                 ) ;_ end of vl-catch-all-apply
               ) ;_ end of vl-catch-all-error-p
             ) ;_ end of not
      (progn
        (cond
          ((= (vla-get-objectname vlaobj) "AcDbRotatedDimension")
           (if
             (vl-catch-all-error-p
               (vl-catch-all-apply 'vla-put-textoverride (list vlaobj pastestr))
               ) ;_ end of vl-catch-all-error-p
              (progn (princ "\n Can't paste. Object may be on locked layer. ")
                     (setq errflag t)
                     ) ;_ end of progn
              ) ;_ end of if
           ) ;#1
          ((= (vla-get-objectname vlaobj) "AcDbTable")
           (setq hitres (vla-hittest
                          vlaobj
                          pt
                          (vlax-3d-point '(0.0 0.0 1.0))
                          'row
                          'column
                          ) ;_ end of vla-HitTest
                 ) ;setq
           (if (= :vlax-true hitres)
             (if (vl-catch-all-error-p
                   (vl-catch-all-apply
                     'vla-settext
                     (list vlaobj row column pastestr)
                     ) ;_ end of vl-catch-all-apply
                   ) ;_ end of vl-catch-all-error-p
               (progn (princ "\n Can't paste. Object may be on locked layer. ")
                      (setq errflag t)
                      ) ;_ end of progn
               ) ;_ end of if
             ) ;_ end of if
           ) ;# 2
          ((= (vla-get-objectname vlaobj) "AcDbBlockReference")
           (princ "\nCan't paste to block's DText or MText. ")
           (setq errflag t)
           ) ;#3
          ((member (vla-get-objectname vlaobj)
                   '("AcDbText" "AcDbMText" "AcDbAttrib" "AcDbAttDef")
                   ) ;_ end of member
           (if
             (vl-catch-all-error-p
               (vl-catch-all-apply 'vla-put-textstring (list vlaobj pastestr))
               ) ;_ end of vl-catch-all-error-p
              (progn (princ "\nError. Can't pase text. ")
                     (setq errflag t)
                     ) ;_ end of progn
              ) ;_ end of if
           ) ;#4
          (t (princ "\nCan't paste. Invalid object. ") (setq errflag t)) ;#5
          ) ;cond
        t
        ) ;progn
      nil
      )   ;if
    )     ; end of TTC_Paste
          ;
  (defun ttc_mtext_clear (mtext / text str)
    (setq text "")
    (while (/= mtext "")
      (cond ((wcmatch (strcase (setq str (substr mtext 1 2))) "\\[\\{}`~]")
             (setq mtext (substr mtext 3)
                   text  (strcat text str)
                   ) ;_ end of setq
             ) ;#1
            ((wcmatch (substr mtext 1 1) "[{}]")
             (setq mtext (substr mtext 2))
             ) ;#2
            ((and (wcmatch (strcase (substr mtext 1 2)) "\\P")
                  (/= (substr mtext 3 1) " ")
                  ) ;and
             (setq mtext (substr mtext 3)
                   text  (strcat text " ")
                   ) ;_ end of setq
             ) ;#3
            ((wcmatch (strcase (substr mtext 1 2)) "\\[LOP]")
             (setq mtext (substr mtext 3))
             ) ;#4
            ((wcmatch (strcase (substr mtext 1 2)) "\\[ACFHQTW]")
             (setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
             ) ;#5
            ((wcmatch (strcase (substr mtext 1 2)) "\\S")
             (setq str   (substr mtext 3 (- (vl-string-search ";" mtext) 2))
                   text  (strcat text (vl-string-translate "#^\\" " " str))
                   mtext (substr mtext (+ 4 (strlen str)))
                   ) ;setq
             (print str)
             ) ;#6
            (t
             (setq text  (strcat text (substr mtext 1 1))
                   mtext (substr mtext 2)
                   ) ;_ end of setq
             ) ;#7
            ) ;cond
      )   ;while
    text
    )     ;TTC_MText_Clear
          ;
  (defun ttc_copy (/ sobj stext)
    (if (not (vl-catch-all-error-p
               (vl-catch-all-apply
                 '(lambda ()
                    (vla-getentity util 'sobj 'pt "\nCopy text >")
                    ) ;_ end of lambda
                 ) ;_ end of vl-catch-all-apply
               ) ;_ end of vl-catch-all-error-p
             ) ;_ end of not
      (if (and sobj
               (member (vla-get-objectname sobj)
                       '("AcDbText" "AcDbMText" "AcDbAttrib" "AcDbAttDef")
                       ) ;_ end of member
               ) ;and
        (progn (setq stext (vla-get-textstring sobj)) ;setq
               (if (= (vla-get-objectname sobj) "AcDbMText")
                 (setq stext (ttc_mtext_clear stext))
                 stext
                 ) ;_ end of if
               ) ;_ end of progn
        ) ;if
      )   ;if
    )     ;TTC_Copy
          ;
  (defun cct_str_echo (pasestr / comstr)
    (if (< 20 (strlen pasestr))
      (setq comstr (strcat (substr pasestr 1 17) "..."))
      (setq comstr pasestr)
      )   ;if
    (princ (strcat "\nText = \"" comstr "\""))
    (princ)
    )     ;CCT_Str_Echo
          ;
  (defun *error* (msg)
    (vla-endundomark astdoc)
    (princ "\nQuit TTC")
    (princ)
    )     ; end of *error*
          ;
  (if (not ttc:mode)
    (setq ttc:mode "Multiple")
    ) ;_ end of if
  (initget "Multiple Pair-wise")
  (setq oldmode  ttc:mode
        ttc:mode (getkword
                   (strcat "\nSpecify mode [Multiple/Pair-wise] <" ttc:mode ">: ")
                   ) ;_ end of getkword
        conflag  t
        pasestr  ""
        ) ;setq
  (if (null ttc:mode)
    (setq ttc:mode oldmode)
    ) ;_ end of if
  (if (= ttc:mode "Multiple")
    (progn (if (and (setq pasestr (ttc_copy)) conflag) ;and
             (progn (cct_str_echo pasestr)
                    (while (setq conflag (ttc_paste pasestr)) t)
                    ) ;_ end of progn
             ) ;_ end of if
           ) ;progn
    (progn (while (and conflag pasestr)
             (setq pasestr (ttc_copy))
             (if (and pasestr conflag)
               (progn (cct_str_echo pasestr)
                      (setq errflag t)
                      (while errflag (setq conflag (ttc_paste pasestr)))
                      ) ;_ end of progn
               ) ;_ end of if
             ) ;_ end of while
           ) ;_ end of progn
    )     ;if
  (vla-endundomark actdoc)
  (princ "\nQuit TTC")
  (princ)
  )       ; end c:ttc

[ASLYS]

error не выдает, но делает что-то странное - просто меняет одни текты на другие...

[Кулик Алексей aka kpblc]

Ну уж ребята тут вопрос не ко мне, а к Лентяю - его творчество (я только одну ошибку исправил, и все).

[Tserber]

Работает!
Прикольно, только зачем непонятно... :shock: