请教关于打散合并属性块的问题

wmz · 发表于 2014-9-30 09:50:11

普通浏览复制代码
;;;;;南方CASS的地形点是用的属性块，他有打散和合并功能，不知是如何实现的
;;;;;我现在用了一种办法但感觉实在是太笨了！请教哪位大侠能指教并帮助优化！
;;;;;以下是我的代码：
(vl-load-com)
;;;打散
(defun c:DSKY (/ bl blc blxs ZG s n s0 s1 d1 m k jd b)
(setq blc (getvar "userr1") blxs (/ blc 1000.0))
(setq bl (* blxs 0.4) ZG (* 2.0 blxs))
(setq s (ssget))
(setq n (sslength s) m 0)
(repeat n
(setq s0 (ssname s m) m (+ m 1) k 0)
(setq s1 (entget s0 (list "SOUTH")))
(setq d1 (cdr(assoc 10 s1)))
(setq JD (cdr(assoc 50 s1)))
(setq b (cdadr (cadr (assoc -3 s1))))
(setq b (vl-princ-to-string b))
(setq b (vl-string-translate "" "" B))
(cond ((= b "202101")(setq height (last d1))
(command "_.erase" s0 "")
(MKINSERT d1 bl bl bl JD "202101")
(MKTEXTA d1 ZG JD (rtos height 2 2) "202111")
)
((= b "186400")(setq H (rtos (last d1) 2 1))
(command "_.erase" s0 "")
(setq k (vl-string-search "." h))
(setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1))
(MKINSERT d1 bl bl bl JD "186400")
(MKTEXTB d1 ZG JD h1 "186411")
(MKTEXTC d1 ZG JD h2 "186412")
)
)
)
)
;;;合并
(defun c:HBKY (/ bl blc blxs ZG lay s n s0 s1 d1 m k jd b)
(command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" "" "")
(setq blc (getvar "userr1") blxs (/ blc 1000.0))
(setq bl (* blxs 0.4) ZG (* 2.0 blxs))
(setq s (ssget))
(setq n (sslength s) m 0)(print "n=")(princ n)(princ)
(repeat n
(setq s0 (ssname s m) m (+ m 1) k 0)
(setq s1 (entget s0 (list "SOUTH")))
(setq lay (cdr(assoc 8 s1)))
(setq e (cdr (assoc 0 s1)))
(if (and(= e "TEXT")(= lay "GCD"))(command "erase" s0 ""))
(if (and(= e "INSERT")(= lay "GCD"))(progn
(setq d1 (cdr(assoc 10 s1)))
(setq JD (cdr(assoc 50 s1)))
(setq b (cdadr (cadr (assoc -3 s1))))
(setq b (vl-princ-to-string b))
(setq b (vl-string-translate "" "" B))
(cond ((= b "202101")(setq height (rtos (last d1) 2 2))
(command "_.erase" s0 "")
(MINSERTAA d1 (/ bl 2.0) height)
)
((= b "186400")(setq H (rtos (last d1) 2 1))
(command "_.erase" s0 "")
(setq k (vl-string-search "." h))
(setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1))
(MINSERTSS d1 (/ bl 2.0) JD h1 h2)
)
)
))
)
)
;;插入块打散后用
(defun MKINSERT (PT SX SY SSZ ZJ DATA)
(entmake (list '(0 . "INSERT")
'(100 . "AcDbBlockReference")
(cons 2 "GC200")
(cons 8 "GCD")
(cons 10 PT)
(cons 41 SX)
(cons 42 SY)
(cons 43 SSZ)
(cons 50 ZJ)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;写文字岸上点打散后用
(defun MKTEXTA (PT HEI ANG STR DATA / PTX TOBJ)
(setq pty (polar pt ANG 0.5))
(entmake (list '(0 . "TEXT")
(cons 7 "HZ")
(cons 8 "GCD")
(cons 10 PT)
(cons 40 HEI) ;;字高
(cons 41 0.8)
(cons 50 ANG)
(cons 1 STR)
(cons 72 0) ;;左对齐
(cons 73 2)
(cons 11 pty)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;写文字水下点左打散后用
(defun MKTEXTB (PT HEI ANG STR DATA / PTz TOBJ)
(setq ptz (polar pt ANG -0.3))
(entmake (list '(0 . "TEXT")
(cons 7 "HZ")
(cons 8 "GCD")
(cons 10 PT)
(cons 40 HEI) ;;字高
(cons 41 0.8)
(cons 50 ANG)
(cons 1 STR)
(cons 11 ptz)
(cons 72 2) ;;右对齐
(cons 73 0)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;写文字水下点右打散后用
(defun MKTEXTC (PT HEI ANG STR DATA / PTy TOBJ)
(setq pty (polar pt ANG 0.2))
(entmake (list '(0 . "TEXT")
(cons 7 "HZ")
(cons 8 "GCD")
(cons 10 PTy)
(cons 40 HEI) ;;字高
(cons 41 0.8)
(cons 50 ANG)
(cons 1 STR)
(cons 11 pty)
(cons 72 0) ;;左对齐
(cons 73 0)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;插入块(岸上点)合并用
(defun MINSERTAA (inspt scale height / pt)
(setq pt (polar inspt 0 (* 1.2 scale)))
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
'(-3 ("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 (* 10.0 scale))
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "HZ")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;插入块(水下点)合并用
(defun MINSERTSS (inspt scale JD integer decimal / pt ptz pty)
(setq pt (polar inspt 0 (* 1.2 scale)))
(setq ptz (polar pt jd -0.4))
(setq pty (polar pt jd 0.2))
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
(cons 50 JD)
'(-3 ("SOUTH" (1000 . "186400")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 (* 10.0 scale))
(cons 50 JD)
(cons 41 0.8)
(cons 51 0)
(cons 1 integer)
(cons 7 "HZ")
(cons 72 2) ;;右对齐
(cons 11 ptz)
'(100 . "AcDbAttribute")
(cons 2 "integer")
(cons 70 0)
(cons 73 2)
(cons 74 1)
)
)
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 (* 10.0 scale))
(cons 50 JD)
(cons 41 0.8)
(cons 51 0)
(cons 1 decimal)
(cons 7 "HZ")
(cons 72 0) ;;左对齐
(cons 11 pty)
'(100 . "AcDbAttribute")
(cons 2 "decimal")
(cons 70 0)
(cons 73 2)
(cons 74 1)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)

普通浏览复制代码 
;;;;;南方CASS的地形点是用的属性块，他有打散和合并功能，不知是如何实现的 
;;;;;我现在用了一种办法但感觉实在是太笨了！请教哪位大侠能指教并帮助优化！ 
;;;;;以下是我的代码： 
 
  (vl-load-com) 
;;;打散 
(defun c:DSKY (/ bl blc blxs ZG s n s0 s1 d1 m k jd b) 
  (setq blc (getvar "userr1") blxs (/ blc 1000.0)) 
  (setq  bl (* blxs 0.4) ZG (* 2.0 blxs)) 
  (setq s (ssget)) 
  (setq n (sslength s) m 0) 
  (repeat n 
    (setq s0 (ssname s m) m (+ m 1) k 0) 
    (setq s1 (entget s0 (list "SOUTH"))) 
    (setq d1 (cdr(assoc 10 s1))) 
    (setq JD (cdr(assoc 50 s1))) 
    (setq  b (cdadr (cadr (assoc -3 s1)))) 
    (setq  b (vl-princ-to-string b)) 
    (setq  b (vl-string-translate "" "" B)) 
    (cond ((= b "202101")(setq height (last d1)) 
     (command "_.erase" s0 "") 
     (MKINSERT d1 bl bl bl JD "202101") 
     (MKTEXTA d1 ZG JD (rtos height 2 2) "202111") 
    ) 
    ((= b "186400")(setq H (rtos (last d1) 2 1)) 
     (command "_.erase" s0 "") 
     (setq k (vl-string-search "." h)) 
     (setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1)) 
     (MKINSERT d1 bl bl bl JD "186400") 
     (MKTEXTB d1 ZG JD h1 "186411") 
     (MKTEXTC d1 ZG JD h2 "186412") 
    ) 
    ) 
  ) 
) 
;;;合并 
(defun c:HBKY (/ bl blc blxs ZG lay s n s0 s1 d1 m k jd b) 
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (setq blc (getvar "userr1") blxs (/ blc 1000.0)) 
  (setq  bl (* blxs 0.4) ZG (* 2.0 blxs)) 
  (setq s (ssget)) 
  (setq n (sslength s) m 0)(print "n=")(princ n)(princ) 
  (repeat n 
    (setq  s0 (ssname s m) m (+ m 1) k 0) 
    (setq  s1 (entget s0 (list "SOUTH"))) 
    (setq lay (cdr(assoc 8 s1))) 
    (setq   e (cdr (assoc 0 s1))) 
    (if (and(= e "TEXT")(= lay "GCD"))(command "erase" s0 "")) 
    (if (and(= e "INSERT")(= lay "GCD"))(progn 
       (setq d1 (cdr(assoc 10 s1))) 
       (setq JD (cdr(assoc 50 s1))) 
       (setq  b (cdadr (cadr (assoc -3 s1)))) 
       (setq  b (vl-princ-to-string b)) 
       (setq  b (vl-string-translate "" "" B)) 
       (cond ((= b "202101")(setq height (rtos (last d1) 2 2)) 
              (command "_.erase" s0 "") 
        (MINSERTAA d1 (/ bl 2.0) height) 
       ) 
       ((= b "186400")(setq H (rtos (last d1) 2 1)) 
        (command "_.erase" s0 "") 
        (setq k (vl-string-search "." h)) 
        (setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1)) 
        (MINSERTSS d1 (/ bl 2.0) JD h1 h2) 
       ) 
       ) 
     )) 
  ) 
) 
;;插入块打散后用 
(defun MKINSERT (PT SX SY SSZ ZJ DATA) 
  (entmake (list '(0 . "INSERT") 
                 '(100 . "AcDbBlockReference") 
                 (cons 2 "GC200") 
                 (cons 8 "GCD") 
                 (cons 10 PT) 
                 (cons 41 SX) 
                 (cons 42 SY) 
                 (cons 43 SSZ) 
                 (cons 50 ZJ) 
                 (list -3 (list "SOUTH" (cons 1000 DATA))) 
            ) 
  ) 
) 
;;;写文字岸上点打散后用 
(defun MKTEXTA (PT HEI ANG STR DATA / PTX TOBJ) 
    (setq pty (polar pt ANG 0.5)) 
    (entmake (list '(0 . "TEXT") 
                   (cons 7 "HZ") 
                   (cons 8 "GCD")       
                   (cons 10 PT) 
                   (cons 40 HEI) ;;字高 
                   (cons 41 0.8)       
                   (cons 50 ANG) 
                   (cons 1 STR) 
                   (cons 72 0)  ;;左对齐 
                   (cons 73 2) 
                   (cons 11 pty) 
                  (list -3 (list "SOUTH" (cons 1000 DATA))) 
              ) 
    ) 
) 
;;;写文字水下点左打散后用 
(defun MKTEXTB (PT HEI ANG STR DATA / PTz TOBJ) 
    (setq ptz (polar pt ANG -0.3)) 
    (entmake (list '(0 . "TEXT") 
                   (cons 7 "HZ") 
                   (cons 8 "GCD")       
                   (cons 10 PT) 
                   (cons 40 HEI) ;;字高 
                   (cons 41 0.8)       
                   (cons 50 ANG) 
                   (cons 1 STR) 
                   (cons 11 ptz) 
                   (cons 72 2)  ;;右对齐 
                   (cons 73 0) 
                   (list -3 (list "SOUTH" (cons 1000 DATA))) 
              ) 
    ) 
) 
;;;写文字水下点右打散后用 
(defun MKTEXTC (PT HEI ANG STR DATA / PTy TOBJ) 
    (setq pty (polar pt ANG 0.2)) 
    (entmake (list '(0 . "TEXT") 
                   (cons 7 "HZ") 
                   (cons 8 "GCD")       
                   (cons 10 PTy) 
                   (cons 40 HEI) ;;字高 
                   (cons 41 0.8)       
                   (cons 50 ANG) 
                   (cons 1 STR) 
                  (cons 11 pty) 
                  (cons 72 0)  ;;左对齐 
                  (cons 73 0) 
                 (list -3 (list "SOUTH" (cons 1000 DATA))) 
              ) 
    ) 
) 
 
;;;插入块(岸上点)合并用 
(defun MINSERTAA (inspt scale height / pt) 
  (setq pt (polar inspt 0 (* 1.2 scale))) 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1);;;属性跟随标志,1跟随，0不跟随 
             (cons 2 "GC200") 
             (cons 10 inspt) 
             (cons 41 scale) 
             (cons 42 scale) 
             (cons 43 scale) 
             '(-3 ("SOUTH" (1000 . "202101"))) 
           ) 
  ) 
  ;;;插入属性 
    (entmake (list 
            '(0 . "ATTRIB") 
            '(100 . "AcDbEntity") 
            '(100 . "AcDbText") 
           (cons 10 pt) 
            (cons 40 (* 10.0 scale)) 
            (cons 50 0) 
            (cons 41 0.8) 
            (cons 51 0) 
            (cons 1 height) 
            (cons 7 "HZ") 
            (cons 72 0) 
            (cons 11 pt) 
            '(100 . "AcDbAttribute") 
            (cons 2 "height") 
            (cons 70 0) 
            (cons 74 2) 
           ) 
    ) 
           ;;;结束标志 
          (entmake '((0 . "SEQEND"))) 
           (princ) 
  ) 
;;;插入块(水下点)合并用 
(defun MINSERTSS (inspt scale JD integer decimal / pt ptz pty) 
  (setq pt (polar inspt 0 (* 1.2 scale))) 
  (setq ptz (polar pt jd -0.4)) 
  (setq pty (polar pt jd 0.2)) 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1);;;属性跟随标志,1跟随，0不跟随 
             (cons 2 "GC200") 
             (cons 10 inspt) 
             (cons 41 scale) 
             (cons 42 scale) 
             (cons 43 scale) 
            (cons 50 JD) 
             '(-3 ("SOUTH" (1000 . "186400"))) 
           ) 
  ) 
  ;;;插入属性 
    (entmake (list 
            '(0 . "ATTRIB") 
            '(100 . "AcDbEntity") 
            '(100 . "AcDbText") 
            (cons 10 pt) 
            (cons 40 (* 10.0 scale)) 
            (cons 50 JD) 
            (cons 41 0.8) 
            (cons 51 0) 
            (cons 1 integer) 
            (cons 7 "HZ") 
            (cons 72 2)  ;;右对齐 
            (cons 11 ptz) 
            '(100 . "AcDbAttribute") 
            (cons 2 "integer") 
            (cons 70 0) 
           (cons 73 2) 
            (cons 74 1) 
           ) 
    ) 
    (entmake (list 
            '(0 . "ATTRIB") 
            '(100 . "AcDbEntity") 
            '(100 . "AcDbText") 
      (cons 10 pt) 
            (cons 40 (* 10.0 scale)) 
            (cons 50 JD) 
            (cons 41 0.8) 
            (cons 51 0) 
            (cons 1 decimal) 
            (cons 7 "HZ") 
            (cons 72 0) ;;左对齐 
            (cons 11 pty) 
            '(100 . "AcDbAttribute") 
            (cons 2 "decimal") 
            (cons 70 0) 
           (cons 73 2) 
            (cons 74 1) 
           ) 
    ) 
           ;;;结束标志 
          (entmake '((0 . "SEQEND"))) 
           (princ) 
  )

gzxl · 发表于 2014-9-30 12:11:55

是ARX的要不要？[em0]

static void xlCassGCDExplode_TEST(void)
{
ads_name ent, ss, ssName;
AcDbObjectId entId;
AcDbEntity *pEnt = NULL;
struct resbuf *rb;
rb = acutBuildList(RTDXF0, TEXT("INSERT"), 2, TEXT("GC200"), RTNONE);
int rt = acedSSGet(TEXT("X"), NULL, NULL, rb, ss);
// int rt = acedSSGet(NULL, NULL, NULL, rb, ss);
if (rt != RTNORM)
{
acutRelRb(rb);
return;
}
acutRelRb(rb);
// 新建图层
CString newLayerName = TEXT("newGCD");
AcDbObjectId layerId = GetLayerId(newLayerName);
if (!layerId.isValid())
{
Add(newLayerName, 4);
}
CString strHeight;
long len;
acedSSLength(ss, &len);
for (int i = 0; i < len; i++)
{
acedSSName(ss, i, ssName);
acdbGetObjectId(entId, ssName);
acdbOpenObject(pEnt, entId, AcDb::kForWrite);
if (pEnt->isKindOf(AcDbBlockReference::desc()))
{
AcDbBlockReference *pBlk = AcDbBlockReference::cast(pEnt);
AcGePoint3d pt = pBlk->position();
int color = pBlk->colorIndex();
CString layerName = pBlk->layer();
AcGeScale3d scale = pBlk->scaleFactors();
AcDbObjectIterator *pAttrIter = pBlk->attributeIterator();
AcDbAttribute *pAttr;
AcDbObjectId attrObjId;
for(int k = 0; !pAttrIter->done(); pAttrIter->step())
{
attrObjId = pAttrIter->objectId();
acdbOpenObject(pAttr,attrObjId, AcDb::kForWrite);
CString pTagStr = pAttr->tag();
// acutDelString(pTagStr);
CString testStr = pAttr->textString(); // 获取文字字符串
AcGePoint3d alignmentPt = pAttr->alignmentPoint(); // 获取对象的对齐点
AcGePoint3d insertionPt = pAttr->position(); // 获取对象的插入点
AcDb::TextHorzMode pHorizontalStr = pAttr->horizontalMode(); // 获取对象水平模式
AcDb::TextVertMode pVerticalStr = pAttr->verticalMode(); // 获取对象垂直对齐模式
double height = pAttr->height(); // 获取对象的高度
double width = pAttr->widthFactor(); // 取得对象的宽度比例
double rotAng = pAttr->rotation(); // 获取对象的旋转角度
AcDbObjectId style = pAttr->textStyle(); // 获取对象的样式名称
AcDbVoidPtrArray pExps;
if (pEnt->explode(pExps) == Acad::eOk)
{
AcDbEntity *pXEnt;
for (int j = 0; j < pExps.length(); j++)
{
pXEnt = (AcDbEntity*)pExps.at(j);
pXEnt->close();
}
}
// 添加文字
AcDbText *pText = new AcDbText(insertionPt, testStr, style, height, rotAng);
pText->setLayer(layerName);
pText->setHorizontalMode(pHorizontalStr);
pText->setVerticalMode(pVerticalStr);
pText->setPosition(insertionPt);
pText->setAlignmentPoint(alignmentPt);
pText->setWidthFactor(width);
pText->setLayer(newLayerName);
// pText->setColorIndex(4);
CString appName = TEXT("SOUTH");
struct resbuf *pRb;
if (_tcscmp(pTagStr, TEXT("height")) == 0)
{
CString typeName = TEXT("202101");
pRb = acutBuildList(AcDb::kDxfRegAppName, appName, AcDb::kDxfXdAsciiString, typeName, RTNONE);
pText->setXData(pRb);
acutRelRb(pRb);
}
else if (_tcscmp(pTagStr, TEXT("integer")) == 0)
{
CString typeName = TEXT("186411");
pRb = acutBuildList(AcDb::kDxfRegAppName, appName, AcDb::kDxfXdAsciiString, typeName, RTNONE);
pText->setXData(pRb);
acutRelRb(pRb);
}
else if (_tcscmp(pTagStr, TEXT("decimal")) == 0)
{
CString typeName = TEXT("186412");
pRb = acutBuildList(AcDb::kDxfRegAppName, appName, AcDb::kDxfXdAsciiString, typeName, RTNONE);
pText->setXData(pRb);
acutRelRb(pRb);
}
else
{
acutRelRb(pRb);
acutPrintf(TEXT("\n无扩展数据"));
}
PostToModelSpace(pText);
// 创建块参照对象
CString blkName = TEXT("GC200");
AcDbObjectId blkDefId = GetBlkDefId(blkName);
AcDbBlockReference *pBlkRef = new AcDbBlockReference(pt, blkDefId);
pBlkRef->setScaleFactors(scale);
pBlkRef->setRotation(rotAng);
pBlkRef->setLayer(newLayerName);
// pBlkRef->setColorIndex(4);
// 扩展数据
if (_tcscmp(pTagStr, TEXT("height")) == 0)
{
struct resbuf *pRb;
CString typeName = TEXT("202101");
pRb = acutBuildList(AcDb::kDxfRegAppName, appName, AcDb::kDxfXdAsciiString, typeName, RTNONE);
pBlkRef->setXData(pRb);
acutRelRb(pRb);
}
else
{
struct resbuf *pRb;
CString typeName = TEXT("186400");
pRb = acutBuildList(AcDb::kDxfRegAppName, appName, AcDb::kDxfXdAsciiString, typeName, RTNONE);
pBlkRef->setXData(pRb);
acutRelRb(pRb);
}
PostToModelSpace(pBlkRef);
// pEnt->erase();
pAttr->close();
k++;
}
delete pAttrIter;
pBlk->close();
}
pEnt->close();
}
acedSSFree(ss);
}

复制代码

gzxl · 发表于 2014-9-30 12:19:11

速度估计比用lisp快

wmz · 发表于 2014-9-30 15:43:09

谢谢！快了好多倍！

wmz · 发表于 2014-10-3 10:46:51

;;;;;南方CASS的地形点是用的属性块，他有打散和合并功能，不知是如何实现的(主要指算法)
;;;;;我现在用LISP写了有此功能的程序，展点，打散，合并等，经改动并与南方cass比较，
;;;;;运行速度几乎不相上下！现贴出来与大家交流探讨！
;;;;;以下是我的代码：
(vl-load-com)
;;;地形展点主程序
(defun c:ZGCD(/ bl fname blxs blc bl sw f pp pt JD y x h ha hb h1 h2 m)
(defun DSJ(PB)
(setq PB (vl-string-translate "," " " PB))
(setq PB (read (strcat "(" PB ")")))
)
(command "insert" "c:/cass80/blocks/gc200.dwg" (list 0 0 0) 1 1 0) ;;;在CASS环境下此句可不要
(command "erase" (entlast) "") ;;;在CASS环境下此句可不要
(regapp "SOUTH") ;;;在CASS环境下此句可不要
(command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" "" "")
(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
(setvar "userr1" 1000.0)
(setq blc (getvar "userr1") blxs (/ blc 1000.0))
(setq bl (* blxs 0.2))
; (setq name (getfiled "输入文件名:" "" "DAT;TXT;*" 8))
(setq fname "F:/lsyy/dxd.dat")
; (setq sw (getreal "输入水位:"))
; (setq JD (getreal "输入水下点高文字旋转角:"))
(setq sw 34.58 jd (/ (* 35 pi) 180.0))
; (setq JD (/ (* JD pi) 180.0))
(setq pp nil)
(setq f (open fname "r"))
(while
(setq pp (read-line f))
(if pp (progn
(setq pp (cdr(DSJ pp)))
(setq y (car pp) x (cadr pp) h (last pp))
(setq pt (list y x h))
(setq ha (rtos h 2 2) hb (rtos h 2 1))
(setq m (vl-string-search "." hb))
(if (= m nil)(progn(setq hb (strcat hb ".0") m (vl-string-search "." hb))));;;在CASS环境下此句可不要
(cond ((>= h sw)(MINSERTA pt bl ha))
((< h sw)(setq h1 (substr hb 1 m) h2 (substr hb (+ m 2) 1))
(MINSERTS pt bl JD h1 h2)
)
)
))
)
(close f)
(command "zoom" "e")
)
;;;打散
(defun c:DSKY (/ bl blc blxs ZG s n s0 s1 d1 m k jd b)
(setq blc (getvar "userr1") blxs (/ blc 1000.0))
(setq bl (* blxs 0.4) ZG (* 2.0 blxs))
(setq s (ssget))
(setq n (sslength s) m 0)
(repeat n
(setq s0 (ssname s m) m (+ m 1) k 0)
(setq s1 (entget s0 (list "SOUTH")))
(setq d1 (cdr(assoc 10 s1)))
(setq JD (cdr(assoc 50 s1)))
(setq b (cdadr (cadr (assoc -3 s1))))
(setq b (vl-princ-to-string b))
(setq b (vl-string-translate "" "" B))
(cond ((= b "202101")(setq height (last d1))
(MKINSERT d1 bl bl bl JD "202101")
(MKTEXTA d1 ZG JD (rtos height 2 2) "202111")
)
((= b "186400")(setq H (rtos (last d1) 2 1))
(setq k (vl-string-search "." h))
(setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1))
(MKINSERT d1 bl bl bl JD "186400")
(MKTEXTB d1 ZG JD h1 "186411")
(MKTEXTC d1 ZG JD h2 "186412")
)
)
)
(command "_.erase" s "")
)
;;;合并
(defun c:HBKY (/ bl blc blxs ZG lay s n s0 s1 d1 m k jd b STIME ETIME)
(command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" "" "")
(setq blc (getvar "userr1") blxs (/ blc 1000.0))
(setq bl (* blxs 0.2) ZG (* 2.0 blxs))
(setq s (ssget))
(setq STIME (getvar "date"))
(setq n (sslength s) m 0)
(repeat n
(setq s0 (ssname s m) m (+ m 1) k 0)
(setq s1 (entget s0 (list "SOUTH")))
(setq lay (cdr(assoc 8 s1)))
(setq e (cdr(assoc 0 s1)))
(if (and(= e "INSERT")(= lay "GCD"))(progn
(setq d1 (cdr(assoc 10 s1)))
(setq JD (cdr(assoc 50 s1)))
(setq b (cdadr (cadr (assoc -3 s1))))
(setq b (vl-princ-to-string b))
(setq b (vl-string-translate "" "" B))
(cond ((= b "202101")(setq height (rtos (last d1) 2 2))
(MINSERTA d1 bl height)
)
((= b "186400")(setq H (rtos (last d1) 2 1))
(setq k (vl-string-search "." h))
(setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1))
(MINSERTS d1 bl JD h1 h2)
)
)
))
)
(command "_.erase" s "")
(setq ETIME (getvar "date"))
(prompt
(strcat
"\n程式共耗用时间: "
(rtos (* 86400.0 (- (- ETIME STIME) (fix (- ETIME STIME)))) 2 3)
"秒"
)
)
)
;;;调用南方CASS命令合并
(defun c:CASShb(/ s STIME)
(setq s (ssget))
(setq STIME (getvar "date"))
(command "resumegcd" s "")
(setq ETIME (getvar "date"))
(prompt
(strcat
"\n程式共耗用时间: "
(rtos (* 86400.0 (- (- ETIME STIME) (fix (- ETIME STIME)))) 2 3)
"秒"
)
)
)
;;插入块打散后用
(defun MKINSERT (PT SX SY SSZ ZJ DATA)
(entmake (list '(0 . "INSERT")
'(100 . "AcDbBlockReference")
(cons 2 "GC200")
(cons 8 "GCD")
(cons 10 PT)
(cons 41 SX)
(cons 42 SY)
(cons 43 SSZ)
(cons 50 ZJ)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;写文字岸上点打散后用
(defun MKTEXTA (PT HEI ANG STR DATA / PTX TOBJ)
(setq pty (polar pt ANG 0.5))
(entmake (list '(0 . "TEXT")
(cons 7 "HZ")
(cons 8 "GCD")
(cons 10 PT)
(cons 40 HEI) ;;字高
(cons 41 0.8)
(cons 50 ANG)
(cons 1 STR)
(cons 72 0) ;;左对齐
(cons 73 2)
(cons 11 pty)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;写文字水下点左打散后用
(defun MKTEXTB (PT HEI ANG STR DATA / PTz TOBJ)
(setq ptz (polar pt ANG -0.8))
(entmake (list '(0 . "TEXT")
(cons 7 "HZ")
(cons 8 "GCD")
(cons 10 PT)
(cons 40 HEI) ;;字高
(cons 41 0.8)
(cons 50 ANG)
(cons 1 STR)
(cons 11 ptz)
(cons 72 2) ;;右对齐
(cons 73 0)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;写文字水下点右打散后用
(defun MKTEXTC (PT HEI ANG STR DATA / PTy TOBJ)
(setq pty (polar pt ANG 0.6))
(entmake (list '(0 . "TEXT")
(cons 7 "HZ")
(cons 8 "GCD")
(cons 10 PTy)
(cons 40 HEI) ;;字高
(cons 41 0.8)
(cons 50 ANG)
(cons 1 STR)
(cons 11 pty)
(cons 72 0) ;;左对齐
(cons 73 0)
(list -3 (list "SOUTH" (cons 1000 DATA)))
)
)
)
;;;插入块(岸上点)
(defun MINSERTA (inspt scale height / pt)
(setq pt (polar inspt 0 (* 1.2 scale)))
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1)
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
'(-3 ("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 (* 10.0 scale))
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "HZ")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;插入块(水下点)
(defun MINSERTS (inspt scale JD integer decimal / pt ptz pty)
(setq pt (polar inspt 0 (* 1.2 scale)))
(setq ptz (polar pt jd -0.8))
(setq pty (polar pt jd 0.5))
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1)
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
(cons 50 JD)
'(-3 ("SOUTH" (1000 . "186400")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 (* 10.0 scale))
(cons 50 JD)
(cons 41 0.8)
(cons 51 0)
(cons 1 integer)
(cons 7 "HZ")
(cons 72 2) ;;右对齐
(cons 11 ptz)
'(100 . "AcDbAttribute")
(cons 2 "integer")
(cons 70 0)
(cons 73 2)
(cons 74 1)
)
)
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt)
(cons 40 (* 10.0 scale))
(cons 50 JD)
(cons 41 0.8)
(cons 51 0)
(cons 1 decimal)
(cons 7 "HZ")
(cons 72 0) ;;左对齐
(cons 11 pty)
'(100 . "AcDbAttribute")
(cons 2 "decimal")
(cons 70 0)
(cons 73 2)
(cons 74 1)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)

;;;;;南方CASS的地形点是用的属性块，他有打散和合并功能，不知是如何实现的(主要指算法) 
;;;;;我现在用LISP写了有此功能的程序，展点，打散，合并等，经改动并与南方cass比较， 
;;;;;运行速度几乎不相上下！现贴出来与大家交流探讨！ 
;;;;;以下是我的代码： 
(vl-load-com) 
;;;地形展点主程序 
(defun c:ZGCD(/ bl fname blxs blc bl sw f pp pt JD y x h ha hb h1 h2 m) 
     (defun DSJ(PB) 
        (setq  PB (vl-string-translate "," " " PB)) 
        (setq  PB (read (strcat "(" PB ")"))) 
     ) 
  (command "insert" "c:/cass80/blocks/gc200.dwg" (list 0 0 0) 1 1 0) ;;;在CASS环境下此句可不要 
  (command "erase" (entlast) "") ;;;在CASS环境下此句可不要 
  (regapp "SOUTH") ;;;在CASS环境下此句可不要 
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "") 
  (setvar "userr1" 1000.0) 
  (setq blc (getvar "userr1") blxs (/ blc 1000.0)) 
  (setq  bl (* blxs 0.2)) 
  ; (setq name (getfiled "输入文件名:" "" "DAT;TXT;*" 8)) 
  (setq fname "F:/lsyy/dxd.dat") 
 ; (setq sw (getreal "输入水位:")) 
 ; (setq JD (getreal "输入水下点高文字旋转角:")) 
  (setq sw 34.58 jd (/ (* 35 pi) 180.0)) 
 ; (setq JD (/ (* JD pi) 180.0)) 
  (setq pp nil) 
  (setq   f (open fname "r")) 
  (while 
    (setq pp (read-line f)) 
    (if pp (progn 
       (setq pp (cdr(DSJ pp))) 
       (setq  y (car pp)  x (cadr pp) h (last pp)) 
       (setq pt (list y x h)) 
       (setq ha (rtos h 2 2) hb (rtos h 2 1)) 
       (setq  m (vl-string-search "." hb)) 
       (if (= m nil)(progn(setq hb (strcat hb ".0") m (vl-string-search "." hb))));;;在CASS环境下此句可不要 
       (cond ((>= h sw)(MINSERTA pt bl ha)) 
             ((<  h sw)(setq h1 (substr hb 1 m) h2 (substr hb (+ m 2) 1)) 
                       (MINSERTS pt bl JD h1 h2) 
             ) 
       )      
     ))   
   ) 
     (close f) 
     (command "zoom" "e") 
) 
;;;打散 
(defun c:DSKY (/ bl blc blxs ZG s n s0 s1 d1 m k jd b) 
  (setq blc (getvar "userr1") blxs (/ blc 1000.0)) 
  (setq  bl (* blxs 0.4) ZG (* 2.0 blxs)) 
  (setq s (ssget)) 
  (setq n (sslength s) m 0) 
  (repeat n 
    (setq s0 (ssname s m) m (+ m 1) k 0) 
    (setq s1 (entget s0 (list "SOUTH"))) 
    (setq d1 (cdr(assoc 10 s1))) 
    (setq JD (cdr(assoc 50 s1))) 
    (setq  b (cdadr (cadr (assoc -3 s1)))) 
    (setq  b (vl-princ-to-string b)) 
    (setq  b (vl-string-translate "" "" B)) 
    (cond ((= b "202101")(setq height (last d1)) 
     (MKINSERT d1 bl bl bl JD "202101") 
     (MKTEXTA d1 ZG JD (rtos height 2 2) "202111") 
    ) 
    ((= b "186400")(setq H (rtos (last d1) 2 1)) 
     (setq k (vl-string-search "." h)) 
     (setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1)) 
     (MKINSERT d1 bl bl bl JD "186400") 
     (MKTEXTB d1 ZG JD h1 "186411") 
     (MKTEXTC d1 ZG JD h2 "186412") 
    ) 
    ) 
  ) 
          (command "_.erase" s "") 
) 
;;;合并 
(defun c:HBKY (/ bl blc blxs ZG lay s n s0 s1 d1 m k jd b STIME ETIME) 
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (setq blc (getvar "userr1") blxs (/ blc 1000.0)) 
  (setq  bl (* blxs 0.2) ZG (* 2.0 blxs)) 
  (setq s (ssget)) 
  (setq STIME (getvar "date")) 
  (setq n (sslength s) m 0) 
  (repeat n 
    (setq  s0 (ssname s m) m (+ m 1) k 0) 
    (setq  s1 (entget s0 (list "SOUTH"))) 
    (setq lay (cdr(assoc 8 s1))) 
    (setq   e (cdr(assoc 0 s1))) 
    (if (and(= e "INSERT")(= lay "GCD"))(progn 
       (setq d1 (cdr(assoc 10 s1))) 
       (setq JD (cdr(assoc 50 s1))) 
       (setq  b (cdadr (cadr (assoc -3 s1)))) 
       (setq  b (vl-princ-to-string b)) 
       (setq  b (vl-string-translate "" "" B)) 
       (cond ((= b "202101")(setq height (rtos (last d1) 2 2)) 
        (MINSERTA d1 bl height) 
       ) 
       ((= b "186400")(setq H (rtos (last d1) 2 1)) 
        (setq k (vl-string-search "." h)) 
        (setq h1 (substr h 1 k) h2 (substr h (+ k 2) 1)) 
        (MINSERTS d1 bl JD h1 h2) 
       ) 
       ) 
     )) 
  ) 
       (command "_.erase" s "") 
  (setq ETIME (getvar "date")) 
  (prompt 
    (strcat 
      "\n程式共耗用时间: " 
      (rtos (* 86400.0 (- (- ETIME STIME) (fix (- ETIME STIME)))) 2 3) 
      "秒" 
    ) 
  ) 
) 
;;;调用南方CASS命令合并 
(defun c:CASShb(/ s STIME) 
  (setq s (ssget)) 
  (setq STIME (getvar "date")) 
  (command "resumegcd" s "") 
  (setq ETIME (getvar "date")) 
  (prompt 
    (strcat 
      "\n程式共耗用时间: " 
      (rtos (* 86400.0 (- (- ETIME STIME) (fix (- ETIME STIME)))) 2 3) 
      "秒" 
    ) 
  ) 
)   
   
;;插入块打散后用 
(defun MKINSERT (PT SX SY SSZ ZJ DATA) 
  (entmake (list '(0 . "INSERT") 
                 '(100 . "AcDbBlockReference") 
                 (cons 2 "GC200") 
     (cons 8 "GCD") 
                 (cons 10 PT) 
                 (cons 41 SX) 
                 (cons 42 SY) 
     (cons 43 SSZ) 
     (cons 50 ZJ) 
                 (list -3 (list "SOUTH" (cons 1000 DATA))) 
            ) 
  ) 
) 
;;;写文字岸上点打散后用 
(defun MKTEXTA (PT HEI ANG STR DATA / PTX TOBJ) 
    (setq pty (polar pt ANG 0.5)) 
    (entmake (list '(0 . "TEXT") 
       (cons 7 "HZ") 
                   (cons 8 "GCD")       
                   (cons 10 PT) 
                   (cons 40 HEI) ;;字高 
                   (cons 41 0.8)       
                   (cons 50 ANG) 
                   (cons 1 STR) 
       (cons 72 0)  ;;左对齐 
       (cons 73 2) 
                   (cons 11 pty) 
       (list -3 (list "SOUTH" (cons 1000 DATA))) 
              ) 
    ) 
) 
;;;写文字水下点左打散后用 
(defun MKTEXTB (PT HEI ANG STR DATA / PTz TOBJ) 
    (setq ptz (polar pt ANG -0.8)) 
    (entmake (list '(0 . "TEXT") 
       (cons 7 "HZ") 
                   (cons 8 "GCD")       
                   (cons 10 PT) 
                   (cons 40 HEI) ;;字高 
                   (cons 41 0.8)       
                   (cons 50 ANG) 
                   (cons 1 STR) 
       (cons 11 ptz) 
       (cons 72 2)  ;;右对齐 
                   (cons 73 0) 
       (list -3 (list "SOUTH" (cons 1000 DATA))) 
              ) 
    ) 
) 
;;;写文字水下点右打散后用 
(defun MKTEXTC (PT HEI ANG STR DATA / PTy TOBJ) 
    (setq pty (polar pt ANG 0.6)) 
    (entmake (list '(0 . "TEXT") 
       (cons 7 "HZ") 
                   (cons 8 "GCD")       
                   (cons 10 PTy) 
                   (cons 40 HEI) ;;字高 
                   (cons 41 0.8)       
                   (cons 50 ANG) 
                   (cons 1 STR) 
       (cons 11 pty) 
       (cons 72 0)  ;;左对齐 
       (cons 73 0) 
       (list -3 (list "SOUTH" (cons 1000 DATA))) 
              ) 
    ) 
) 
;;;插入块(岸上点) 
(defun MINSERTA (inspt scale height / pt) 
  (setq pt (polar inspt 0 (* 1.2 scale))) 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1) 
             (cons 2 "GC200") 
             (cons 10 inspt) 
             (cons 41 scale) 
             (cons 42 scale) 
             (cons 43 scale) 
             '(-3 ("SOUTH" (1000 . "202101"))) 
           ) 
  ) 
  ;;;插入属性 
    (entmake (list 
            '(0 . "ATTRIB") 
            '(100 . "AcDbEntity") 
            '(100 . "AcDbText") 
      (cons 10 pt) 
            (cons 40 (* 10.0 scale)) 
            (cons 50 0) 
            (cons 41 0.8) 
            (cons 51 0) 
            (cons 1 height) 
            (cons 7 "HZ") 
            (cons 72 0) 
            (cons 11 pt) 
            '(100 . "AcDbAttribute") 
            (cons 2 "height") 
            (cons 70 0) 
            (cons 74 2) 
           ) 
    ) 
           ;;;结束标志 
          (entmake '((0 . "SEQEND"))) 
           (princ) 
  ) 
;;;插入块(水下点) 
(defun MINSERTS (inspt scale JD integer decimal / pt ptz pty) 
  (setq pt (polar inspt 0 (* 1.2 scale))) 
  (setq ptz (polar pt jd -0.8)) 
  (setq pty (polar pt jd 0.5)) 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1) 
             (cons 2 "GC200") 
             (cons 10 inspt) 
             (cons 41 scale) 
             (cons 42 scale) 
             (cons 43 scale) 
       (cons 50 JD) 
             '(-3 ("SOUTH" (1000 . "186400"))) 
           ) 
  ) 
  ;;;插入属性 
    (entmake (list 
            '(0 . "ATTRIB") 
            '(100 . "AcDbEntity") 
            '(100 . "AcDbText") 
      (cons 10 pt) 
            (cons 40 (* 10.0 scale)) 
            (cons 50 JD) 
            (cons 41 0.8) 
            (cons 51 0) 
            (cons 1 integer) 
            (cons 7 "HZ") 
            (cons 72 2)  ;;右对齐 
            (cons 11 ptz) 
            '(100 . "AcDbAttribute") 
            (cons 2 "integer") 
            (cons 70 0) 
      (cons 73 2) 
            (cons 74 1) 
           ) 
    ) 
    (entmake (list 
            '(0 . "ATTRIB") 
            '(100 . "AcDbEntity") 
            '(100 . "AcDbText") 
      (cons 10 pt) 
            (cons 40 (* 10.0 scale)) 
            (cons 50 JD) 
            (cons 41 0.8) 
            (cons 51 0) 
            (cons 1 decimal) 
            (cons 7 "HZ") 
            (cons 72 0) ;;左对齐 
            (cons 11 pty) 
            '(100 . "AcDbAttribute") 
            (cons 2 "decimal") 
            (cons 70 0) 
      (cons 73 2) 
            (cons 74 1) 
           ) 
    ) 
           ;;;结束标志 
          (entmake '((0 . "SEQEND"))) 
           (princ) 
  )

树櫴希德 · 发表于 2014-10-7 23:02:16

5楼跟1楼是一样的吗
？

wmz · 发表于 2014-10-8 09:07:33

树櫴希德发表于 2014-10-7 23:02
5楼跟1楼是一样的吗
？

略有优化，但这一小小的优化，速度就上去了，关键在于仅改动了一处，即将删除原块命令一句挪动了一个位置：
(command "_.erase" s0 "")这一句改成(command "_.erase" s "")放到最后一起删除，原来放在循环里面处理一
点删除一点，致使速度慢了好多，仅此而已。

ji3499222 · 发表于 2014-12-10 08:44:58

谢谢楼主，我最喜欢这样的小插件。

jxy308 · 发表于 2014-12-20 15:51:29

jxy308 · 发表于 2014-12-22 08:10:25

谢谢分享!辛苦了

账号		自动登录	找回密码
密码			注册

请教关于打散合并属性块的问题

相关帖子

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源