[编程交流] 向多段线和ex添加数据

(defun c:dwrite(/ plObj stBl enBl datLst)
 (vl-load-com)
 (if
   (and
     (setq plObj(entsel "\nSelect polyline to write > "))
     (setq stBl(entsel "\nSelect 'start' block > "))
     (setq enBl(entsel "\nSelect 'end' block > "))
     ); end and
   (progn
   (setq plObj(vlax-ename->vla-object(car plObj))
  stBl(cdr(assoc 2(entget(car stBl))))
  enBl(cdr(assoc 2(entget(car enBl))))
  datLst(list(cons 1 stBl)(cons 2 enBl))
  ); end setq
   (vlax-ldata-put plObj "Pipe Data" datLst)
   ); end progn
  );end if
 (princ)
 ); c:dwrite
 
(defun c:dread(/ rObj datLst)
 (vl-load-com)
 (if(and
      (setq rObj(entsel "\nSelect polyline to read > "))
      (setq datLst(vlax-ldata-get(car rObj) "Pipe Data"))
      ); and
   (alert(strcat "Start block: "(cdr(assoc 1 datLst))
                 "\n\nEnd block: "(cdr(assoc 2 datLst))))
   (alert "\nNo data found. ")
   ); end if
 (princ)
 ); end of c:dread

(defun c:dwrite(/ plObj stBl enBl datLst cAns hyObj)
 (if
   (and
     (setq plObj(entsel "\nSelect polyline to write > "))
     (setq stBl(entsel "\nSelect 'Begin' block > "))
     (setq enBl(entsel "\nSelect 'End' block > "))
     ); end and
   (progn
   (setq plObj(vlax-ename->vla-object(car plObj))
  stBl(cdr(assoc 2(entget(car stBl))))
  enBl(cdr(assoc 2(entget(car enBl))))
  datLst(list(cons 1 stBl)(cons 2 enBl))
  hyObj(vla-get-Hyperlinks plObj)
  ); end setq
   (if(vlax-ldata-get plObj "Pipe Data")
     (progn
(initget "Yes No")
(setq cAns(getkword "\nPipe data already exists. Overwrite? [Yes/No]: "))
(if(= "Yes" cAns)
  (progn
   (vlax-ldata-delete plObj "Pipe Data")
   (vlax-ldata-put plObj "Pipe Data" datLst)
   (vla-Delete(vla-Item hyObj 0))
   (vla-Add hyObj "Has Pipe Data" (strcat "Pipe: " stBl " --> " enBl))
   (princ "\nData successfuly added ")
   );end progn
  ); end if
); end progn
     (progn
      (vlax-ldata-put plObj "Pipe Data" datLst)
      (vla-Add hyObj "Has Pipe Data" (strcat "Pipe: " stBl " --> " enBl))
      (princ "\nData successfuly added ")
      ); end progn
     ); end if
   ); end progn
  );end if
 (princ)
 ); c:dwrite
(defun c:dcollect(/ plSet oLst cDat fName cAns exApp wbCol cDoc)
 (if(setq plSet(ssget "_X" '((0 . "LWPOLYLINE"))))
   (progn
     (foreach pl (mapcar 'vlax-ename->vla-object
                    (vl-remove-if 'listp
                      (mapcar 'cadr(ssnamex plSet))))
(if(setq cDat(vlax-ldata-get pl "Pipe Data"))
  (progn
    (setq oLst(cons
                (list
                     (vla-get-ConstantWidth pl)
                     (vla-get-Layer pl)
                     (cdr(assoc 1 cDat))
                     (cdr(assoc 2 cDat))
                    ); end list
              oLst); end cons
          ); end setq
    ); end progn
  ); end if
); end foreach
     (if oLst
(progn
  (setq fDescr(open
                (setq fName(strcat(vl-filename-directory(getvar "SAVENAME"))
                  "\"(vl-filename-base(getvar "DWGNAME")) ".csv")) "w"))
  (write-line "Diameter;Layer;From;To" fDescr)
  (foreach itm (reverse oLst)
      (write-line (strcat(rtos(car itm))
                         ";" (cadr itm)
                         ";" (nth 2 itm)
                         ";" (last itm))
        fDescr)
    ); end foreach
  (close fDescr)
  (princ(strcat "\nCSV file location: " fName ))
  (initget "Yes No")
  (setq cAns(getkword "\nOpen file [Yes/No]: "))
  (if(= cAns "Yes")
    (if(setq exApp(vlax-get-or-create-object "Excel.Application"))
      (progn
        (vlax-put-property exApp 'Visible :vlax-true)
        (setq wbCol(vlax-get-property exApp 'Workbooks)
              cDoc(vlax-invoke-method wbCol 'Open fName))
        (vlax-release-object cDoc)
        (vlax-release-object wbCol)
        (vlax-release-object exApp)
        ); end progn
      ); end if
    ); end if
  ); end progn
); end if
     ); end progn
   ); end if
 (princ)
 ); end of c:dtable
(vl-load-com)

(defun c:dwrite(/ plObj stBl enBl datLst cAns hyObj okFlg cMat mLst mNum)
; ************ MODIFY LIST OF MATERIALS ************
 (setq mLst '(
       (0 . "N/A")
       (1 . "DIN 2391")
       (2 . "DIN 2392")
       (3 . "DIN 2394")
       )
); end setq
 
; ************ MODIFY DEFAULT MATERIAL ************
 (if(not dwrite:material)
    (setq dwrite:material "N/A")
   ); end if
 
 
 
 (defun Entsel_or_Text(Spaces Message / lChr tStr grLst filPt
                selSet outVal pSps)
 (princ Message)
 (setq tStr ""); end setq
 (if Spaces
   (setq pSps(list "\r"))
   (setq pSps(list " " "\r"))
   ); end if
  (while
     (and
       (not(member lChr pSps))
(/= 3(car grLst))
       ); end and
     (if
       (setq grLst(grread nil 4 2))
       (progn
        (cond
         ((= 3(car grLst))
          (setq filPt(cadr grLst)
                selSet(ssget filPt)
                ); end setq
          (if selSet
               (setq outVal
               (list(ssname selSet 0)filPt))
            ); end if
          ); end condition #1
  ((or
     (equal '(2 13) grLst)
     (equal 25(car grLst))
     ); end or
    (setq lChr "\r"
          outVal tStr); end setq
   ); end condition #2
  ((and
     (equal '(2  grLst)
     (< 0(strlen tStr))
     ); end and
   (setq tStr(substr tStr 1(1-(strlen tStr))))
   (princ(strcat(chr (chr 32)(chr ))
   ); end condition #3
         ((and
     (= 2(car grLst))
     (<= 32(cadr grLst)126)
     ); end and
          (setq lChr(chr(cadr grLst)))
          (if(not(member lChr pSps))
                (progn
                (setq tStr(strcat tStr lChr)
                      outVal tStr); end setq
            (princ lChr)
          ); end progn
         ); end if
        ); end condition #4
       ); end cond
      ); end progn
     ); end if
    ); end while
   outVal
); end of Entsel_or_Text
 
 (while(not okFlg)
   (princ(strcat "\nCurrent material = " dwrite:material))
   (setq plObj(Entsel_or_Text T "\nSelect polyline or [Material]: "))
   (cond
     ((and
  (= 'LIST(type plObj))
  (= "LWPOLYLINE"(cdr(assoc 0(entget(car plObj)))))
 ); end and
      (setq plObj(car plObj)
     okFlg T); end setq
      ); end condition #1
     ((= 'LIST(type plObj))
      (princ "\nThis isn't LwPolyline! ")
      ); end condition #2
     ((and
 (= 'STR(type plObj))
 (member(strcase plObj) '("M" "_M" "MATERIAL" "_MATERIAL"))
 
 ); end and
      (textscr)
      (princ "\n====== MATERIAL LIST ======")
      (foreach m mLst
 (princ(strcat "\n[" (itoa(car m)) "] - "(cdr m)))
 ); end foreach
      (princ "\n===========================")
      (setq mNum(getint "\nSelect material from list: "))
      (if(and mNum(setq cMat(assoc mNum mLst)))
 (progn
   (setq dwrite:material(cdr cMat))
   (graphscr)
   ); end progn
 (princ "\nCan't find material with this number! ")
 ); end if
      ); end condition #3
     ((null plObj)
       (princ "\nEmpty selection! ")
      ); end condition #4
     (T
      (princ "\nInvalid keyword option! ")
      ); end condition #5
     ); end cond
   ); end while
 (while(not stBl)
   (setq stBl(Entsel_or_Text T "\nSelect 'Begin' block or type name: "))
   (cond
     ((and
 (= 'LIST(type stBl))
 (= "INSERT"(cdr(assoc 0(entget(car stBl)))))
); end and
       (setq stBl(cdr(assoc 2(entget(car stBl)))))
      ); end condition #1
     ((= 'LIST(type stBl))
       (princ "\nThis isn't block! ")
       (setq stBl nil)
      ); end condition #2
     ((null stBl)
      (princ "\nEmpty input! ")
      ); end condition #3
     ); end cond
   ); end while
(while(not enBl)
   (setq enBl(Entsel_or_Text T "\nSelect 'End' block or type name: "))
   (cond
     ((and
 (= 'LIST(type enBl))
 (= "INSERT"(cdr(assoc 0(entget(car enBl)))))
); end and
       (setq enBl(cdr(assoc 2(entget(car enBl)))))
      ); end condition #1
     ((= 'LIST(type enBl))
       (princ "\nThis isn't block! ")
       (setq enBl nil)
      ); end condition #2
     ((null enBl)
      (princ "\nEmpty input! ")
      ); end condition #3
     ); end cond
   ); end while
 (setq datLst(list(cons 1 stBl)(cons 2 enBl)(cons 3 dwrite:material))
plObj(vlax-ename->vla-object plObj)
hyObj(vla-get-Hyperlinks plObj)
); end setq
 (if(vlax-ldata-get plObj "PipeData")
     (progn
(initget "Yes No")
(setq cAns(getkword "\nPipe data already exists. Overwrite? [Yes/No]: "))
(if(= "Yes" cAns)
  (progn
   (vlax-ldata-delete plObj "PipeData")
   (vlax-ldata-put plObj "PipeData" datLst)
   (vla-Delete(vla-Item hyObj 0))
   (vla-Add hyObj "Has Pipe Data" (strcat "Material: " dwrite:material))
   (princ "\n<<< Data successfuly added >>> ")
   );end progn
  ); end if
); end progn
     (progn
      (vlax-ldata-put plObj "PipeData" datLst)
      (vla-Add hyObj "Has Pipe Data" (strcat "Material: " dwrite:material))
      (princ "\n<<< Data successfuly added >>> ")
      ); end progn
     ); end if        
 (princ)
); c:dwrite
(defun c:dcollect(/ plSet oLst cDat fName cAns exApp wbCol cDoc)
 (if(setq plSet(ssget "_X" '((0 . "LWPOLYLINE"))))
   (progn
     (foreach pl (mapcar 'vlax-ename->vla-object
                    (vl-remove-if 'listp
                      (mapcar 'cadr(ssnamex plSet))))
(if(setq cDat(vlax-ldata-get pl "PipeData"))
  (progn
    (setq oLst(cons
                (list
                     (vla-get-ConstantWidth pl)
                     (vla-get-Layer pl)
                     (cdr(assoc 1 cDat))
                     (cdr(assoc 2 cDat))
                     (cdr(assoc 3 cDat))
                     (vlax-curve-GetDistAtParam pl
                       (vlax-curve-GetEndParam pl))
                    ); end list
              oLst); end cons
          ); end setq
    ); end progn
  ); end if
); end foreach
     (if oLst
(progn
  (setq fDescr(open
                (setq fName(strcat(vl-filename-directory(getvar "SAVENAME"))
                  "\"(vl-filename-base(getvar "DWGNAME")) ".csv")) "w"))
  (write-line "Diameter;Layer;From;To;Material;Length" fDescr)
  (foreach itm (reverse oLst)
      (write-line (strcat(rtos(* 1000.0(nth 0 itm)))
                         ";" (nth 1 itm)
                         ";" (nth 2 itm)
                         ";" (nth 3 itm)
                         ";" (nth 4 itm)
                         ";" (rtos(nth 5 itm)))
        fDescr)
    ); end foreach
  (close fDescr)
  (princ(strcat "\nCSV file location: " fName ))
  (initget "Yes No")
  (setq cAns(getkword "\nOpen file [Yes/No]: "))
  (if(= cAns "Yes")
    (if(setq exApp(vlax-get-or-create-object "Excel.Application"))
      (progn
        (vlax-put-property exApp 'Visible :vlax-true)
        (setq wbCol(vlax-get-property exApp 'Workbooks)
              cDoc(vlax-invoke-method wbCol 'Open fName))
        (vlax-release-object cDoc)
        (vlax-release-object wbCol)
        (vlax-release-object exApp)
        ); end progn
      ); end if
    ); end if
  ); end progn
(princ "\nNo data found! ")
); end if
     ); end progn
   ); end if
 (princ)
 ); end of c:dcollect
(vl-load-com)