[编程交流] 在华氏15度时进行转换

CREATES DOUBLE LINE DUCT WITH CAPS AND CORNERS, NO TRANSITIONS
(defun c:dpipe(/ actDoc ang1 ang2 ang3 ptLst enDist
       fPt lEnt lObj lPln oldVars oldWd
       plEnd plStart1 plStart2 prDir
       segLst Start stDist stLst tAng
       vlaPln *error*)
 
 (vl-load-com)
 (defun GetPlineVer(plObj)
   (mapcar 'cdr
    (vl-remove-if-not
     '(lambda(x)(=(car x)10))
     (entget plObj)))
   ); end of GetPLineVer
 (defun asmi-PlineSegmentDataList(plObj / cLst outLst)
  (setq cLst
   (vl-remove-if-not
     '(lambda(x)(member(car x) '(10 40 41 42)))
     (entget plObj))
    outLst '()
   ); end setq
 (while cLst
   (if(assoc 40 cLst)
     (progn
      (setq outLst
     (append outLst
      (list
 (list
   (cdr(assoc 10 cLst))
   (cdr(assoc 40 cLst))
   (cdr(assoc 41 cLst))
   (cdr(assoc 42 cLst))
  ); end list
); end list
     ); end if
); end setq
      (repeat 4
(setq cLst(cdr cLst))
); end repeat
      ); end progn
     (setq outLst
     (append outLst
     (list
       (list
  (cdr(assoc 10 cLst))
 ); end list
       ); end list
    ); end append
   cLst nil
   ); end setq
     ); end if
   ); end while
 outLst
   ); end of asmi-GetPlineSegmentData
 (defun asmi-LayersUnlock(/ restLst)
 (setq restLst '())
 (vlax-for lay
   (vla-get-Layers
            (vla-get-ActiveDocument
              (vlax-get-acad-object)))
   (setq restLst
    (append restLst
      (list
        (list
         lay
          (vla-get-Lock lay)
  (vla-get-Freeze lay)
         ); end list
        ); end list
      ); end append
   ); end setq
   (vla-put-Lock lay :vlax-false)
   (if
     (vl-catch-all-error-p
(vl-catch-all-apply
 'vla-put-Freeze(list lay :vlax-false)))
     t)
   ); end vlax-for
 restLst
 ); end of asmi-LayersUnlock
 (defun asmi-LayersStateRestore(StateList)
 (foreach lay StateList
   (vla-put-Lock(car lay)(cadr lay))
    (if
     (vl-catch-all-error-p
(vl-catch-all-apply
 'vla-put-Freeze(list(car lay)(nth 2 lay))))
     t)
   ); end foreach
 (princ)
    ); end of asmi-LayersStateRestore
 (defun PipeMLineStyle(/ dxfLst mlDict)
 (setq dxfLst
  (list'(0 . "MLINESTYLE")'(102 . "{ACAD_REACTORS")'(102 . "}")
   '(100 . "AcDbMlineStyle") '(2 . "DUCT_PIPE")
   '(70 . 272)'(3 . "")'(62 . 256)'(51 . 1.5708)'(52 . 1.5708)
   '(71 . 2)'(49 . 0.5)'(62 . 256)'(6 . "BYBLOCK")
   '(49 . -0.5)'(62 . 256)'(6 . "BYBLOCK"))); end setq
   (if
    (null
     (member
      (assoc 2 dxfLst)
        (dictsearch
  (namedobjdict)
  "ACAD_MLINESTYLE")))
   (progn
     (setq mlDict
      (cdr
        (assoc -1
  (dictsearch
    (namedobjdict)
    "ACAD_MLINESTYLE"))))
     (dictadd mlDict
        (cdr(assoc 2 dxfLst))(entmakex dxfLst))
     ); end progn
   ); end if
); end of PipeMLineStyle
(defun SideCalculate(Rad Ang)
 (setq Ang(- pi Ang))
 (*
   (/
     (sqrt(-(* 2(expt Rad 2))(* 2(expt Rad 2)(cos Ang))))
     (sin(- pi Ang)))(sin(/(- pi(- pi Ang))2)
    )
   )
 ); end of SideCalculate
 (defun *error*(msg)
   (setvar "CMDECHO" 0)
   (if lObj
     (command "_.erase"(entnext lObj)"")
     (command "_.erase"(entlast)"")
     ); end if
   (if oldVars
     (mapcar 'setvar
     '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE")
     oldVars); end mapcar
    ); end if
   (if stLst
     (asmi-LayersStateRestore stLst)
     ); end if
    (if actDoc
     (vla-EndUndoMark actDoc)
     ); end if
   (princ "*Cancel* ")
   (princ)
   ); end of *error*
 (PipeMLineStyle)
 
 (if(not dpipepWd)(setq dpipepWd 1.0))
 (setq oldWd dpipepWd
       dpipepWd(getdist
              (strcat "\nSpecify first segment width <" (rtos dpipepWd) ">: "))
oldVars(mapcar 'getvar '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE"))
       ); end setq
 (if(null dpipepWd)(setq dpipepWd oldWd))
 (mapcar 'setvar
 '("FILLMODE" "PLINEWID" "CMDECHO")
 (list 0 dpipepWd 1)); end mapcar
 (if(entlast)(setq lObj(entlast)))
 (vla-StartUndoMark
  (setq actDoc
   (vla-get-ActiveDocument
     (vlax-get-acad-object))))
  (setq fPt
 (getpoint "\nSpecify start point: ")
    ); end setq
 (command "_.pline" fPt)
 (while(= 1(getvar "CMDACTIVE"))
   (command pause)
   ); end while
 (if
   (not
     (equal lObj(entlast)))
(progn
 (setq lEnt(entlast)
       stLst(asmi-LayersUnlock)
  segLst(asmi-PlineSegmentDataList lEnt)
  vlaPln(vlax-ename->vla-object lEnt)
 ); end setq
 (setvar "OSMODE" 0)
 (setvar "CMDECHO" 0)
 (while (/= 1(length segLst))
      (setq stDist
      (vlax-curve-getDistAtPoint vlaPln
 (caar segLst))
     enDist
      (vlax-curve-getDistAtPoint vlaPln
 (caadr segLst))
     ); end setq
   (if(< 2(length segLst))
     (progn
      (setq ang1
      (+(/ pi 2)(angle(caar segLst)(caadr segLst)))
     ang2
      (+(/ pi 2)(angle(caadr segLst)(car(nth 2 segLst))))
     ); end setq
      ); end progn
     ); end if
   (if
     (or
(not Start)
prDir
);end or
      (setq plStart1
       (vlax-curve-getPointAtDist vlaPln
  stDist)
     Start T); end setq
      (setq plStart1
       (vlax-curve-getPointAtDist vlaPln
  (+ stDist(SideCalculate(cadar segLst)ang3)))); end setq
     ); end if
     (if(and ang1 ang2)
     (progn
     (if(> ang1 ang2)
 (setq ang3(- ang1 ang2))
 (setq ang3(- ang2 ang1))
 ); end if
      (setq ang3(- pi ang3)
     tAng ang3)
      (if(minusp ang3)(setq ang3(- ang3)))
      ); end progn
     ); end if
   (if
     (or
       (equal ang1 ang2 0.000001)
(= 2(length segLst))
      ); end or
        (setq plEnd
           (vlax-curve-getPointAtDist vlaPln
    enDist)
 prDir T); end setq
         (setq plEnd
           (vlax-curve-getPointAtDist vlaPln
     (- enDist(SideCalculate(cadar segLst)ang3)))
 prDir nil); end setq
     ); end if
   (if
     (< 2(length segLst))
      (setq plStart2
       (vlax-curve-getPointAtDist vlaPln
  (+ enDist(SideCalculate(cadar segLst)ang3)))); end setq
     ); end if
      (if(< 2(length segLst))
       (if
  (=(cadar segLst)(nth 2(car segLst)))
   (setq ptLst
                    (mapcar
       '(lambda(x)(trans x 0 1)); end lambda
                (list(polar plEnd ang1 (/(cadar segLst)2))
       (polar plEnd (+ pi ang1)(/(cadar segLst)2))
       (polar plStart2 (+ pi ang2)(/(cadar segLst)2))
       (polar plStart2 ang2 (/(cadar segLst)2))
        ); end list
           ); end mapcar
  ); end setq
  (setq ptLst
    (mapcar
     '(lambda(x)(trans x 0 1)); end lambda
        (list (polar plStart1 ang1 (/(cadar segLst)2))
       (polar plStart1 (+ pi ang1)(/(cadar segLst)2))
       (polar(caadr segLst)(+ pi ang2)(/(nth 2(car segLst))2))
       (polar(caadr segLst)ang2(/(nth 2(car segLst))2))
       ); end list
           ); end mapcar
  ); end setq
       ); end if
 ); end if
     (setq plStart1(trans plStart1 0 1)
      plEnd(trans plEnd 0 1)
  ); end setq
    (if plStart2
       (setq plStart2(trans plStart1 0 1))
      ); end if
      (if
 (and
   (< 2(length segLst))
  (or
      (not(equal ang1 ang2 0.000001))
      (/=(cadar segLst)(nth 2(car segLst)))
    ); end or
   ); end and
      (progn
        (setvar "PLINEWID" 0.0)
        (command "_.pline")
 (mapcar 'command ptLst)(command "_c")
        (setvar "PLINEWID" dpipepWd)
); end progn
 ); end if
   (if
     (and
       (not(equal ang1 ang2 0.000001))
       (< 2(length segLst))
     ); end and
     (progn
       (setq lPln
      (vlax-ename->vla-object(entlast))
      tAng(- ang2 ang1)
     ); end setq
       (if(minusp tAng)(setq tAng(- tAng)))
        (if
   (and
    (< 0 tAng)
    (>= pi tAng)
    ); end and
  (progn
         (vla-SetBulge lPln 1 (/(- ang2 ang1)4))
         (vla-SetBulge lPln 3 (/(- ang1 ang2)4))
         ); end progn
  (progn
    (if(< ang1 ang2)
      (setq ang1(+ ang1 pi)
     ang2(- ang2 pi)); end setq
      (setq ang1(- ang1 pi)
     ang2(+ ang2 pi)); end setq
      ); end if
     (vla-SetBulge lPln 1 (/(- ang2 ang1)4))
         (vla-SetBulge lPln 3 (/(- ang1 ang2)4))
    ); end progn
  ); end if
      ); end progn
 ); end if
 (if
   (=(cadar segLst)(nth 2(car segLst)))
     (command "_.mline" "_st" "DUCT_PIPE"
 "_S" (cadar segLst) "_J" "_Z"
 plStart1 plEnd "")
   ); end if
   
   (setq segLst(cdr segLst)); end setq
   ); end while
 (command "_.erase" lEnt "")
 (asmi-LayersStateRestore stLst)
 ); end progn
   ); end if
 (vla-EndUndoMark actDoc)
(mapcar 'setvar
     '("FILLMODE" "PLINEWID" "CMDECHO" "OSMODE")
     oldVars); end apply
 (princ)
 ); end of c:dpipeAttached Images
  
--------------------------------------------------------------------------------
Last edited by ASMI : 24th Feb 2007 at 07:29 am. Reason: Fixed small bug