[原创]：带属性序号球，有动态拖拽效果，欢迎测试使用！[源码免币] （第二版）

Dallas_whu · 发表于 2006-11-8 15:05:26

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

欢迎各位测试使用！含注释，欢迎提出修改建议及简化方法！程序中含动态旋转的“奔驰”三角星标志，纯属好玩。

[COLOR] 本段代码为第一版，第二版见10楼，增加少许功能！[/COLOR]

;;属性序号球 BY HB.LEE 2006-11-08；
;;得到晓东cad舟自横指点，动态移动时采用VLA-PUT-INSERTPOINT；
;;序号球子程序参考LUCUS (C:MBA) 程序。
(PRINC "\n*** 带属性序号球绘制, 命令: GJ . BY HB.Lee 2006-11-08. ***")
(DEFUN C:GJ (/ ATTBALL BL DEFNUM FIRSTPT
NUM OLDATTD OLDATTR OLDCMD OLDLAY
OLDOS SECONDPT STARTPT STR VPREATT)
(VL-LOAD-COM)
;;错误处理函数
(DEFUN *$MYERROR$* (MSG)
(REDRAW)
(SETVAR "OSMODE" OLDOS)
(SETVAR "CLAYER" OLDLAY)
(SETVAR "ATTREQ" OLDATTR)
(SETVAR "ATTDIA" OLDATTD)
(SETVAR "CURSORSIZE" OLDCURS)
;;确保出错时插入的块能删除
(IF ATTBALL
(ENTDEL ATTBALL))
(IF NUM
(VL-REGISTRY-WRITE
(STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" "GJH")
"GJH"
(ITOA NUM)
)
)
(SETVAR "CMDECHO" OLDCMD)
(SETQ *ERROR* &OLDERR&)
(PRINC)
)
(SETQ &OLDERR& *ERROR*)
(SETQ *ERROR* *$MYERROR$*)
(SETQ OLDLAY (GETVAR "CLAYER"))
(SETQ OLDOS (GETVAR "OSMODE"))
(SETQ OLDCMD (GETVAR "CMDECHO"))
(SETQ OLDATTR (GETVAR "ATTREQ"))
(SETQ OLDATTD (GETVAR "ATTDIA"))
(SETQ OLDCURS (GETVAR "CURSORSIZE"))
(SETVAR "CMDECHO" 0)
(COMMAND ".UNDO" "BE")
(SETQ DEFNUM
(LHB-REGSAVE-INT "GJH" "1" "\n请输入序号的开始值" 6 "U")
)
(SETQ BL (GETVAR "DIMSCALE"))
(SETQ NUM DEFNUM)
(SETQ STR (ITOA NUM))
;;捕捉方式设定
(SETVAR "OSMODE" (+ 1 2 32 128 512))
(SETVAR "ATTREQ" 1)
(SETVAR "ATTDIA" 0)
(SETQ STARTPT (GETPOINT "\n请输入构件号引出点:"))
(WHILE STARTPT
(IF (NULL (TBLOBJNAME "BLOCK" "LHB_NO"))
(PROGN
(ENTMAKE_ATT (* BL 2.5) STR)
(SETQ FIRSTPT (VLAX-MAKE-SAFEARRAY
VLAX-VBDOUBLE
'(0 . 2)))
(VLAX-SAFEARRAY-FILL FIRSTPT '(0.0 0.0 0.0))
(SETQ SECONDPT (VLAX-MAKE-SAFEARRAY
VLAX-VBDOUBLE
'(0 . 2)))
(VLAX-SAFEARRAY-FILL
SECONDPT
(POLAR STARTPT 0 (* BL 2.5)))
(SETQ VPREATT (VLAX-ENAME->VLA-OBJECT (ENTLAST)))
(VLA-MOVE VPREATT FIRSTPT SECONDPT)
)
;;属性块插入
(COMMAND "-INSERT"
"LHB_NO"
(POLAR STARTPT 0 (* BL 2.5))
1
1
0
STR
)
)
(SETQ ATTBALL (ENTLAST))
;;动态预览
(VIEW_GJ ATTBALL STARTPT BL)
(SETQ ATTBALL NIL)
(SETQ NUM (1+ NUM))
(SETQ STR (ITOA NUM))
(SETVAR "OSMODE" (+ 1 2 32 128 512))
(INITGET "B")
(SETQ
STARTPT
(GETPOINT
(STRCAT
"\n请输入构件号引出点/改变序号(B)/[当前序号<"
STR
">]:"
)
)
)
(WHILE (OR (= STARTPT "B") (= STARTPT "b"))
(VL-REGISTRY-WRITE
(STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" "GJH")
"GJH"
(ITOA NUM)
)
(SETQ DEFNUM
(LHB-REGSAVE-INT
"GJH" "1"
"\n请输入序号的开始值"
6 "U")
)
(SETQ NUM DEFNUM)
(SETQ STR (ITOA NUM))
(SETQ STARTPT
(GETPOINT
(STRCAT
"\n请输入构件号引出点/改变序号(B)/[当前序号<"
STR
">]:"
)
)
)
)
)
(VL-REGISTRY-WRITE
(STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" "GJH")
"GJH"
(ITOA NUM)
)
(SETVAR "CLAYER" OLDLAY)
(SETVAR "ATTREQ" OLDATTR)
(SETVAR "ATTDIA" OLDATTD)
(SETVAR "CURSORSIZE" OLDCURS)
(COMMAND ".UNDO" "E")
(SETVAR "OSMODE" OLDOS)
(SETVAR "CMDECHO" OLDCMD)
(SETQ *ERROR* &OLDERR&)
;(PRINC "\n*** 构件号绘制[ COMMAND:GJ ], BY HB.LEE 06-11-08 *** ")
(PRINC)
)
;;;构件编号动态预览
(DEFUN VIEW_GJ (VOBJ VBASEPT VBL / DIST FIRSTPT
LOOP_ID NEWCENPT PT1 PT10 PT11
PT12 PT2 PT3 PT4 PT5 PT6
PT7 PT8 PT9 VANGLE VPOINT VPOINTENT
MOVEPT)
(SETQ LOOP_ID T)
(SETQ ALPHA 0)
(SETVAR "CURSORSIZE" 1) ;将光标大小设置为1，最小尺寸
(PRINC "\n请输入构件号标注点:")
(WHILE LOOP_ID
(SETQ VPOINTENT (GRREAD T 4 1))
(IF (= 5 (CAR VPOINTENT)) ;鼠标跟踪
(PROGN
(REDRAW)
(SETQ VPOINT (CADR VPOINTENT))
(SETQ MOVEPT VPOINT) ;记录直线第二点
(SETQ DIST (DISTANCE VBASEPT VPOINT))
(SETQ VANGLE (ANGLE VBASEPT VPOINT))
(SETQ NEWCENPT (POLAR VBASEPT
VANGLE
(+ DIST (* VBL 2.5))))
(SETQ FIRSTPT (VLAX-MAKE-SAFEARRAY
VLAX-VBDOUBLE
'(0 . 2)))
(VLAX-SAFEARRAY-FILL FIRSTPT NEWCENPT)
(VLA-PUT-INSERTIONPOINT
(VLAX-ENAME->VLA-OBJECT VOBJ)
FIRSTPT)
(GRVECS (LIST 2 VBASEPT VPOINT))
;;================================================================
;;动态旋转“奔驰”标志,此段可去掉，纯属好玩。
;;标注点标志
(SETQ PT1 (POLAR VPOINT (+ ALPHA (* PI 0.5)) (* VBL 1.0))
PT2 (POLAR VPOINT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0))
PT3 (POLAR VPOINT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0))
PT4 (POLAR VPOINT (+ ALPHA (/ (* PI 5) 6)) (* VBL 0.268))
PT5 (POLAR VPOINT (+ ALPHA (* PI 1.5)) (* VBL 0.268))
PT6 (POLAR VPOINT (+ ALPHA (/ PI 6)) (* VBL 0.268))
)
(GRVECS (LIST 1 PT1 VPOINT 1 PT2 VPOINT
1 PT3 VPOINT 6 PT4 VPOINT
6 PT5 VPOINT 6 PT6 VPOINT
6 PT1 PT4 6 PT4 PT2 6
PT2 PT5 6 PT5 PT3 6 PT3
PT6 6 PT6 PT1)
)
;;引出点标志
(SETQ PT7 (POLAR VBASEPT (+ ALPHA (* PI 0.5)) (* VBL 1.0))
PT8 (POLAR VBASEPT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0))
PT9 (POLAR VBASEPT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0))
PT10 (POLAR VBASEPT
(+ ALPHA (/ (* PI 5) 6))
(* VBL 0.268))
PT11 (POLAR VBASEPT (+ ALPHA (* PI 1.5)) (* VBL 0.268))
PT12 (POLAR VBASEPT (+ ALPHA (/ PI 6)) (* VBL 0.268))
)
(GRVECS (LIST 1 PT7 VBASEPT 1 PT8
VBASEPT 1 PT9 VBASEPT
5 PT10 VBASEPT 5 PT11
VBASEPT 5 PT12 VBASEPT
5 PT7 PT10 5 PT10 PT8
5 PT8 PT11 5 PT11 PT9
5 PT9 PT12 5 PT12 PT7)
)
;;设置三角星旋转速度，若想加快可将0.056适当加大，如0.112.
(SETQ ALPHA (+ ALPHA (* PI 0.056)))
;;================================================================
)
)
;; 若点击鼠标左、右键或键盘任意按键，则取得当前鼠标位置，并绘制符号
(IF (OR (= 3 (CAR VPOINTENT))
(= 2 (CAR VPOINTENT))
(= 11 (CAR VPOINTENT))
)
(PROGN
(REDRAW)
(SETQ LOOP_ID NIL)
;;绘制直线
(SETVAR "CLAYER" "构件符号")
(COMMAND "_.LINE" VBASEPT MOVEPT "")
)
)
) ;END WHILE
(SETVAR "CURSORSIZE" OLDCURS)
(PRINC)
) ;DEFUN VIEW_GJ
;;建立属性编号
(DEFUN ENTMAKE_ATT (CIRRAD TEXT / CHK_LAYER CHK_STYLE BLKNAME BLKN LST0
LST1)
;;建立编号圆圈图层
(SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件符号"))
(IF (= CHK_LAYER NIL)
(PROGN
(ENTMAKE (LIST
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(6 . "continuous") ;线型
'(62 . 2) ;颜色
'(70 . 0) ;图层状态
(CONS 2 "构件符号") ;图层名
)
)
)
)
;;建立编号文字图层
(SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件编号"))
(IF (= CHK_LAYER NIL)
(PROGN
(ENTMAKE (LIST
'(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(6 . "continuous") ;线型
'(62 . 6) ;颜色
'(70 . 0) ;图层状态
'(2 . "构件编号") ;图层名
)
)
)
)
;;建立编号文字字型
(SETQ CHK_STYLE (TBLSEARCH "STYLE" "NUM_STYLE"))
(IF (= CHK_STYLE NIL)
(ENTMAKE (LIST
'(0 . "STYLE") ;对象名称
'(100 . "AcDbSymbolTableRecord")
'(100
.
"AcDbTextStyleTableRecord") ;子类标记
'(2 . "NUM_STYLE") ;字体样式名
'(70 . 0) ;标注位码
'(40 . 0.0) ;文字高度
'(41 . 0.7) ;宽度系数
'(50 . 0.0) ;字斜角
'(71 . 0) ;文字生成标注位码2＝反向，4＝颠倒
'(3 . "TSSDENG.shx") ;西文字体名
'(4 . "HZTXT.shx") ;中文字体名
) ;_ 结束LIST
) ;_ 结束ENTMAKE
) ;_ 结束IF
;;设置属性块名
(SETQ BLKNAME "LHB_NO")
(ENTMAKE
(LIST '(0 . "BLOCK")
(CONS 2 BLKNAME) ;图块名称
'(70 . 2) ;设置属性块是否可以编辑
'(10 0.0 0.0 0.0)) ;基准点
)
(ENTMAKE (LIST '(0 . "CIRCLE")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "构件符号") ;图层名称
'(100 . "CIRCLE")
'(10 0.0 0.0 0.0) ;中心点
(CONS 40 CIRRAD) ;半径
'(210 0.0 0.0 1.0)
)
)
(ENTMAKE (LIST '(0 . "ATTDEF")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "构件编号") ;图层名称
'(100 . "AcDbText")
'(10 -1.08 -1.75 0.0) ;文字起点
(CONS 40 (+ CIRRAD 1.0)) ;文字高度
'(1 . "A") ;默认值
'(50 . 0) ;文字旋转
'(41 . 0.7) ;相对X比例系数
'(51 . 0.0) ;倾斜角度
'(7 . "NUM_STYLE") ;文字字型
'(71 . 0) ;文字产生的标志
'(72 . 1) ;水平文字的对齐类型
'(11 0.0 0.0 0.0) ;对齐点，只有在72与74非0才有意义
'(210 0.0 0.0 1.0) ;挤出方向
'(100 . "AcDbAttributeDefinition")
'(3 . "编号属性") ;提示字符串
'(2 . "A") ;卷标字符串
'(70 . 0) ;属性标志
'(73 . 0) ;字段长度
'(74 . 2) ;垂直文字的对齐类型
)
)
(SETQ BLKN (ENTMAKE '((0 . "ENDBLK"))))
(SETQ LST0 (LIST '(0 . "INSERT") '(100 . "AcDbEntity") '(67 . 0)
'(8 . "构件符号") ;图层
'(100 . "AcDbBlockReference") '(66 . 1) '(10 0.0 0.0 0.0)
;插入点
'(41 . 1.0) ;x
'(42 . 1.0) ;y
'(43 . 1.0) ;z
'(50 . 0.0) ;旋转角度
'(70 . 0) ;插入行数
'(71 . 0) ;插入列数
'(44 . 0.0) ;行间距
'(45 . 0.0) ;列间距
'(210 0.0 0.0 1.0))
)
(SETQ LST1 (APPEND LST0 (LIST (CONS 2 BLKN))))
(ENTMAKE LST1)
(ENTMAKE (LIST '(0 . "ATTRIB")
'(5 . "26")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "构件编号") ;图层名称
'(100 . "AcDbText")
'(10 -1.08 -1.75 0.0) ;文字起点
(CONS 40 (+ CIRRAD 1.0)) ;文字高度
(CONS 1 TEXT) ;默认值
'(50 . 0) ;文字旋转
'(41 . 0.7) ;相对X比例系数
'(51 . 0.0) ;倾斜角度
'(7 . "NUM_STYLE") ;文字字型
'(71 . 0) ;文字产生的标志
'(72 . 1) ;水平文字的对齐类型
'(11 0.0 0.0 0.0) ;对齐点，只有在72与74非0才有意义
'(210 0.0 0.0 1.0) ;挤出方向
'(100 . "AcDbAttribute")
(CONS 2 TEXT) ;卷标字符串
'(70 . 0) ;属性标志
'(73 . 0) ;字段长度
'(74 . 2) ;垂直文字的对齐类型
)
)
(ENTMAKE '((0 . "SEQEND")))
(PRINC)
) ;DEFUN ENTMAKE_ATT
;;输入字符串记录函数，记录入注册表的相应位置
(DEFUN LHB-REGSAVE-INT
(KEY-PATH DEF-VAL MSG BITS KWORD / READSTR NEWSTR)
(SETQ READSTR
(VL-REGISTRY-READ
(STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" KEY-PATH)
KEY-PATH
)
)
(IF (= READSTR NIL)
(SETQ READSTR DEF-VAL)
)
(GRAPHSCR)
(IF (AND READSTR (/= READSTR ""))
(SETQ MSG (STRCAT "\n" MSG "<" READSTR ">:")
READSTR (ATOI READSTR)
)
(SETQ MSG (STRCAT "\n" MSG ":"))
)
(INITGET BITS KWORD)
(SETQ NEWSTR (GETINT MSG))
(IF (NOT NEWSTR)
(SETQ NEWSTR READSTR)
)
(IF (AND NEWSTR (/= NEWSTR "") (= 'INT (TYPE NEWSTR)))
(VL-REGISTRY-WRITE
(STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" KEY-PATH)
KEY-PATH
(ITOA NEWSTR)
)
)
(IF NEWSTR
NEWSTR
SETSTR
)
) ;DEFUN LHB-REGSAVE-INT

;;属性序号球  BY HB.LEE 2006-11-08； 
;;得到晓东cad舟自横指点，动态移动时采用VLA-PUT-INSERTPOINT； 
;;序号球子程序参考LUCUS (C:MBA) 程序。 
(PRINC "\n*** 带属性序号球绘制, 命令: GJ . BY HB.Lee  2006-11-08. ***") 
(DEFUN C:GJ  (/                ATTBALL          BL            DEFNUM    FIRSTPT 
              NUM        OLDATTD          OLDATTR   OLDCMD    OLDLAY 
              OLDOS        SECONDPT  STARTPT   STR              VPREATT) 
    (VL-LOAD-COM) 
    ;;错误处理函数 
    (DEFUN *$MYERROR$*        (MSG) 
        (REDRAW) 
        (SETVAR "OSMODE" OLDOS) 
        (SETVAR "CLAYER" OLDLAY) 
        (SETVAR "ATTREQ" OLDATTR) 
        (SETVAR "ATTDIA" OLDATTD) 
        (SETVAR "CURSORSIZE" OLDCURS) 
        ;;确保出错时插入的块能删除 
        (IF ATTBALL 
            (ENTDEL ATTBALL)) 
        (IF NUM 
            (VL-REGISTRY-WRITE 
                (STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" "GJH") 
                "GJH" 
                (ITOA NUM) 
                ) 
            ) 
        (SETVAR "CMDECHO" OLDCMD) 
        (SETQ *ERROR* &OLDERR&) 
        (PRINC) 
        ) 
    (SETQ &OLDERR& *ERROR*) 
    (SETQ *ERROR* *$MYERROR$*) 
    (SETQ OLDLAY (GETVAR "CLAYER")) 
    (SETQ OLDOS (GETVAR "OSMODE")) 
    (SETQ OLDCMD (GETVAR "CMDECHO")) 
    (SETQ OLDATTR (GETVAR "ATTREQ")) 
    (SETQ OLDATTD (GETVAR "ATTDIA")) 
    (SETQ OLDCURS (GETVAR "CURSORSIZE")) 
    (SETVAR "CMDECHO" 0) 
    (COMMAND ".UNDO" "BE") 
    (SETQ DEFNUM 
             (LHB-REGSAVE-INT "GJH" "1" "\n请输入序号的开始值" 6 "U") 
          ) 
    (SETQ BL (GETVAR "DIMSCALE")) 
    (SETQ NUM DEFNUM) 
    (SETQ STR (ITOA NUM)) 
    ;;捕捉方式设定 
    (SETVAR "OSMODE" (+ 1 2 32 128 512)) 
    (SETVAR "ATTREQ" 1) 
    (SETVAR "ATTDIA" 0) 
    (SETQ STARTPT (GETPOINT "\n请输入构件号引出点:")) 
    (WHILE STARTPT 
        (IF (NULL (TBLOBJNAME "BLOCK" "LHB_NO")) 
            (PROGN 
                (ENTMAKE_ATT (* BL 2.5) STR) 
                (SETQ FIRSTPT (VLAX-MAKE-SAFEARRAY 
                                  VLAX-VBDOUBLE 
                                  '(0 . 2))) 
                (VLAX-SAFEARRAY-FILL FIRSTPT '(0.0 0.0 0.0)) 
                (SETQ SECONDPT (VLAX-MAKE-SAFEARRAY 
                                   VLAX-VBDOUBLE 
                                   '(0 . 2))) 
                (VLAX-SAFEARRAY-FILL 
                    SECONDPT 
                    (POLAR STARTPT 0 (* BL 2.5))) 
                (SETQ VPREATT (VLAX-ENAME->VLA-OBJECT (ENTLAST))) 
                (VLA-MOVE VPREATT FIRSTPT SECONDPT) 
                ) 
            ;;属性块插入 
            (COMMAND "-INSERT" 
                     "LHB_NO" 
                     (POLAR STARTPT 0 (* BL 2.5)) 
                     1 
                     1 
                     0 
                     STR 
                     ) 
            ) 
        (SETQ ATTBALL (ENTLAST)) 
        ;;动态预览 
        (VIEW_GJ ATTBALL STARTPT BL) 
        (SETQ ATTBALL NIL) 
        (SETQ NUM (1+ NUM)) 
        (SETQ STR (ITOA NUM)) 
        (SETVAR "OSMODE" (+ 1 2 32 128 512)) 
        (INITGET "B") 
        (SETQ 
            STARTPT 
               (GETPOINT 
                   (STRCAT 
                       "\n请输入构件号引出点/改变序号(B)/[当前序号<" 
                       STR 
                       ">]:" 
                       ) 
                   ) 
            ) 
        (WHILE (OR (= STARTPT "B") (= STARTPT "b")) 
            (VL-REGISTRY-WRITE 
                (STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" "GJH") 
                "GJH" 
                (ITOA NUM) 
                ) 
            (SETQ DEFNUM 
                     (LHB-REGSAVE-INT 
                         "GJH"                 "1" 
                         "\n请输入序号的开始值" 
                         6                 "U") 
                  ) 
            (SETQ NUM DEFNUM) 
            (SETQ STR (ITOA NUM)) 
            (SETQ STARTPT 
                     (GETPOINT 
                         (STRCAT 
                             "\n请输入构件号引出点/改变序号(B)/[当前序号<" 
                             STR 
                             ">]:" 
                             ) 
                         ) 
                  ) 
            ) 
        ) 
    (VL-REGISTRY-WRITE 
        (STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" "GJH") 
        "GJH" 
        (ITOA NUM) 
        ) 
    (SETVAR "CLAYER" OLDLAY) 
    (SETVAR "ATTREQ" OLDATTR) 
    (SETVAR "ATTDIA" OLDATTD) 
    (SETVAR "CURSORSIZE" OLDCURS) 
    (COMMAND ".UNDO" "E") 
    (SETVAR "OSMODE" OLDOS) 
    (SETVAR "CMDECHO" OLDCMD) 
    (SETQ *ERROR* &OLDERR&) 
    ;(PRINC "\n***  构件号绘制[ COMMAND:GJ ], BY HB.LEE 06-11-08  *** ") 
    (PRINC) 
    ) 
 
 
;;;构件编号动态预览 
(DEFUN VIEW_GJ        (VOBJ         VBASEPT VBL         /         DIST         FIRSTPT 
                 LOOP_ID NEWCENPT         PT1         PT10         PT11 
                 PT12         PT2         PT3         PT4         PT5         PT6 
                 PT7         PT8         PT9         VANGLE         VPOINT         VPOINTENT 
                 MOVEPT) 
    (SETQ LOOP_ID T) 
    (SETQ ALPHA 0) 
    (SETVAR "CURSORSIZE" 1)                ;将光标大小设置为1，最小尺寸 
    (PRINC "\n请输入构件号标注点:") 
    (WHILE LOOP_ID 
        (SETQ VPOINTENT (GRREAD T 4 1)) 
        (IF (= 5 (CAR VPOINTENT))        ;鼠标跟踪 
            (PROGN 
                (REDRAW) 
                (SETQ VPOINT (CADR VPOINTENT)) 
                (SETQ MOVEPT VPOINT)        ;记录直线第二点 
                (SETQ DIST (DISTANCE VBASEPT VPOINT)) 
                (SETQ VANGLE (ANGLE VBASEPT VPOINT)) 
                (SETQ NEWCENPT (POLAR VBASEPT 
                                      VANGLE 
                                      (+ DIST (* VBL 2.5)))) 
                (SETQ FIRSTPT (VLAX-MAKE-SAFEARRAY 
                                  VLAX-VBDOUBLE 
                                  '(0 . 2))) 
                (VLAX-SAFEARRAY-FILL FIRSTPT NEWCENPT) 
                (VLA-PUT-INSERTIONPOINT 
                    (VLAX-ENAME->VLA-OBJECT VOBJ) 
                    FIRSTPT) 
                (GRVECS (LIST 2 VBASEPT VPOINT)) 
                ;;================================================================ 
                ;;动态旋转“奔驰”标志,此段可去掉，纯属好玩。 
                ;;标注点标志 
                (SETQ PT1 (POLAR VPOINT (+ ALPHA (* PI 0.5)) (* VBL 1.0)) 
                      PT2 (POLAR VPOINT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0)) 
                      PT3 (POLAR VPOINT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0)) 
                      PT4 (POLAR VPOINT (+ ALPHA (/ (* PI 5) 6)) (* VBL 0.268)) 
                      PT5 (POLAR VPOINT (+ ALPHA (* PI 1.5)) (* VBL 0.268)) 
                      PT6 (POLAR VPOINT (+ ALPHA (/ PI 6)) (* VBL 0.268)) 
                      ) 
                (GRVECS        (LIST 1            PT1          VPOINT      1            PT2          VPOINT 
                              1            PT3          VPOINT      6            PT4          VPOINT 
                              6            PT5          VPOINT      6            PT6          VPOINT 
                              6            PT1          PT4        6     PT4   PT2          6 
                              PT2   PT5          6        PT5   PT3   6          PT3 
                              PT6   6          PT6        PT1) 
                        ) 
                ;;引出点标志 
                (SETQ PT7  (POLAR VBASEPT (+ ALPHA (* PI 0.5)) (* VBL 1.0)) 
                      PT8  (POLAR VBASEPT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0)) 
                      PT9  (POLAR VBASEPT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0)) 
                      PT10 (POLAR VBASEPT 
                                  (+ ALPHA (/ (* PI 5) 6)) 
                                  (* VBL 0.268)) 
                      PT11 (POLAR VBASEPT (+ ALPHA (* PI 1.5)) (* VBL 0.268)) 
                      PT12 (POLAR VBASEPT (+ ALPHA (/ PI 6)) (* VBL 0.268)) 
                      ) 
                (GRVECS        (LIST 1             PT7    VBASEPT          1         PT8 
                              VBASEPT            1           PT9          VBASEPT 
                              5             PT10   VBASEPT          5         PT11 
                              VBASEPT            5           PT12          VBASEPT 
                              5             PT7    PT10   5          PT10         PT8 
                              5             PT8    PT11   5          PT11         PT9 
                              5             PT9    PT12   5          PT12         PT7) 
                        ) 
                ;;设置三角星旋转速度，若想加快可将0.056适当加大，如0.112. 
                (SETQ ALPHA (+ ALPHA (* PI 0.056))) 
                ;;================================================================ 
                ) 
            ) 
        ;; 若点击鼠标左、右键或键盘任意按键，则取得当前鼠标位置，并绘制符号 
        (IF (OR        (= 3 (CAR VPOINTENT)) 
                (= 2 (CAR VPOINTENT)) 
                (= 11 (CAR VPOINTENT)) 
                ) 
            (PROGN 
                (REDRAW) 
                (SETQ LOOP_ID NIL) 
                ;;绘制直线 
                (SETVAR "CLAYER" "构件符号") 
                (COMMAND "_.LINE" VBASEPT MOVEPT "") 
                ) 
            ) 
        )                                ;END WHILE 
    (SETVAR "CURSORSIZE" OLDCURS) 
    (PRINC) 
    )                                        ;DEFUN VIEW_GJ 
 
;;建立属性编号 
(DEFUN ENTMAKE_ATT  (CIRRAD TEXT / CHK_LAYER CHK_STYLE BLKNAME BLKN LST0 
                     LST1) 
    ;;建立编号圆圈图层 
    (SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件符号")) 
    (IF        (= CHK_LAYER NIL) 
        (PROGN 
            (ENTMAKE (LIST 
                         '(0 . "LAYER") 
                         '(100 . "AcDbSymbolTableRecord") 
                         '(100 . "AcDbLayerTableRecord") 
                         '(6 . "continuous") ;线型 
                         '(62 . 2)        ;颜色 
                         '(70 . 0)        ;图层状态 
                         (CONS 2 "构件符号") ;图层名 
                         ) 
                     ) 
            ) 
        ) 
 
    ;;建立编号文字图层 
    (SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件编号")) 
    (IF        (= CHK_LAYER NIL) 
        (PROGN 
            (ENTMAKE (LIST 
                         '(0 . "LAYER") 
                         '(100 
                           . 
                           "AcDbSymbolTableRecord") 
                         '(100 . "AcDbLayerTableRecord") 
                         '(6 . "continuous") ;线型 
                         '(62 . 6)        ;颜色 
                         '(70 . 0)        ;图层状态 
                         '(2 . "构件编号") ;图层名 
                         ) 
                     ) 
            ) 
        ) 
 
    ;;建立编号文字字型 
    (SETQ CHK_STYLE (TBLSEARCH "STYLE" "NUM_STYLE")) 
    (IF        (= CHK_STYLE NIL) 
        (ENTMAKE (LIST 
                     '(0 . "STYLE")        ;对象名称 
                     '(100 . "AcDbSymbolTableRecord") 
                     '(100 
                       . 
                       "AcDbTextStyleTableRecord") ;子类标记 
                     '(2 . "NUM_STYLE")        ;字体样式名 
                     '(70 . 0)                ;标注位码 
                     '(40 . 0.0)        ;文字高度 
                     '(41 . 0.7)        ;宽度系数 
                     '(50 . 0.0)        ;字斜角 
                     '(71 . 0)                ;文字生成标注位码2＝反向，4＝颠倒 
                     '(3 . "TSSDENG.shx") ;西文字体名 
                     '(4 . "HZTXT.shx")        ;中文字体名 
                     ) ;_ 结束LIST 
                 ) ;_ 结束ENTMAKE 
        ) ;_ 结束IF 
    
    ;;设置属性块名 
    (SETQ BLKNAME "LHB_NO") 
 
    (ENTMAKE 
        (LIST '(0 . "BLOCK") 
              (CONS 2 BLKNAME)                ;图块名称 
              '(70 . 2)                        ;设置属性块是否可以编辑 
              '(10 0.0 0.0 0.0))        ;基准点 
        ) 
    (ENTMAKE (LIST '(0 . "CIRCLE") 
                   '(100 . "AcDbEntity") 
                   '(67 . 0) 
                   '(8 . "构件符号")        ;图层名称 
                   '(100 . "CIRCLE") 
                   '(10 0.0 0.0 0.0)        ;中心点 
                   (CONS 40 CIRRAD)        ;半径 
                   '(210 0.0 0.0 1.0) 
                   ) 
             ) 
    (ENTMAKE (LIST '(0 . "ATTDEF") 
                   '(100 . "AcDbEntity") 
                   '(67 . 0) 
                   '(8 . "构件编号")        ;图层名称 
                   '(100 . "AcDbText") 
                   '(10 -1.08 -1.75 0.0) ;文字起点 
                   (CONS 40 (+ CIRRAD 1.0)) ;文字高度 
                   '(1 . "A")                ;默认值 
                   '(50 . 0)                ;文字旋转 
                   '(41 . 0.7)                ;相对X比例系数 
                   '(51 . 0.0)                ;倾斜角度 
                   '(7 . "NUM_STYLE")        ;文字字型 
                   '(71 . 0)                ;文字产生的标志 
                   '(72 . 1)                ;水平文字的对齐类型 
                   '(11 0.0 0.0 0.0)        ;对齐点，只有在72与74非0才有意义 
                   '(210 0.0 0.0 1.0)        ;挤出方向 
                   '(100 . "AcDbAttributeDefinition") 
                   '(3 . "编号属性")        ;提示字符串 
                   '(2 . "A")                ;卷标字符串 
                   '(70 . 0)                ;属性标志 
                   '(73 . 0)                ;字段长度 
                   '(74 . 2)                ;垂直文字的对齐类型 
                   ) 
             ) 
    (SETQ BLKN (ENTMAKE '((0 . "ENDBLK")))) 
    (SETQ LST0 (LIST '(0 . "INSERT") '(100 . "AcDbEntity") '(67 . 0) 
                     '(8 . "构件符号")        ;图层 
                     '(100 . "AcDbBlockReference") '(66 . 1) '(10 0.0 0.0 0.0) 
                                        ;插入点 
                     '(41 . 1.0)        ;x 
                     '(42 . 1.0)        ;y 
                     '(43 . 1.0)        ;z 
                     '(50 . 0.0)        ;旋转角度 
                     '(70 . 0)                ;插入行数 
                     '(71 . 0)                ;插入列数 
                     '(44 . 0.0)        ;行间距 
                     '(45 . 0.0)        ;列间距 
                     '(210 0.0 0.0 1.0)) 
          ) 
    (SETQ LST1 (APPEND LST0 (LIST (CONS 2 BLKN)))) 
    (ENTMAKE LST1) 
    (ENTMAKE (LIST '(0 . "ATTRIB") 
                   '(5 . "26") 
                   '(100 . "AcDbEntity") 
                   '(67 . 0) 
                   '(8 . "构件编号")        ;图层名称 
                   '(100 . "AcDbText") 
                   '(10 -1.08 -1.75 0.0) ;文字起点 
                   (CONS 40 (+ CIRRAD 1.0)) ;文字高度 
                   (CONS 1 TEXT)        ;默认值 
                   '(50 . 0)                ;文字旋转 
                   '(41 . 0.7)                ;相对X比例系数 
                   '(51 . 0.0)                ;倾斜角度 
                   '(7 . "NUM_STYLE")        ;文字字型 
                   '(71 . 0)                ;文字产生的标志 
                   '(72 . 1)                ;水平文字的对齐类型 
                   '(11 0.0 0.0 0.0)        ;对齐点，只有在72与74非0才有意义 
                   '(210 0.0 0.0 1.0)        ;挤出方向 
                   '(100 . "AcDbAttribute") 
                   (CONS 2 TEXT)        ;卷标字符串 
                   '(70 . 0)                ;属性标志 
                   '(73 . 0)                ;字段长度 
                   '(74 . 2)                ;垂直文字的对齐类型 
                   ) 
             ) 
    (ENTMAKE '((0 . "SEQEND"))) 
    (PRINC) 
    )                                        ;DEFUN ENTMAKE_ATT 
 
;;输入字符串记录函数，记录入注册表的相应位置 
(DEFUN LHB-REGSAVE-INT 
       (KEY-PATH DEF-VAL MSG BITS KWORD / READSTR NEWSTR) 
    (SETQ READSTR 
             (VL-REGISTRY-READ 
                 (STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" KEY-PATH) 
                 KEY-PATH 
                 ) 
          ) 
    (IF        (= READSTR NIL) 
        (SETQ READSTR DEF-VAL) 
        ) 
    (GRAPHSCR) 
    (IF        (AND READSTR (/= READSTR "")) 
        (SETQ MSG     (STRCAT "\n" MSG "<" READSTR ">:") 
              READSTR (ATOI READSTR) 
              ) 
        (SETQ MSG (STRCAT "\n" MSG ":")) 
        ) 
    (INITGET BITS KWORD) 
    (SETQ NEWSTR (GETINT MSG)) 
    (IF        (NOT NEWSTR) 
        (SETQ NEWSTR READSTR) 
        ) 
    (IF        (AND NEWSTR (/= NEWSTR "") (= 'INT (TYPE NEWSTR))) 
        (VL-REGISTRY-WRITE 
            (STRCAT "HKEY_CURRENT_USER\\LHBTOOLS\" KEY-PATH) 
            KEY-PATH 
            (ITOA NEWSTR) 
            ) 
        ) 
    (IF        NEWSTR 
        NEWSTR 
        SETSTR 
        ) 
    )                                        ;DEFUN LHB-REGSAVE-INT

若不需要源程序，请下载编译文件。命令：GJ 。

carrot1983 · 发表于 2006-11-8 19:39:08

看起来好像真的很好玩似的,学习学习.

命令: APPLOAD 已成功加载属性序号球GJ.lsp。
已成功加载属性序号球GJ.lsp。
命令:
** 带属性序号球绘制, 命令: GJ . BY HB.Lee 2006-11-08. ***; 错误:
输入中的点位置不正确.
命令: gj 未知命令“GJ”。按 F1 查看帮助。

这是怎么一回事啊?没去想太多,只是把上面的代码复制到记事本然后另存为"GJ.lsp".
然后在CAD2004加载完了以后就这样子了~!

Dallas_whu · 发表于 2006-11-8 21:40:11

看一下复制全了没，或下载编译文件试一试吧，我没碰到过这种问题！

zxcvbnm-cad · 发表于 2006-11-8 22:49:35

我出现二楼同样的问题
请楼主检查一下
另编译文件不能下载

fsxm · 发表于 2006-11-8 23:28:46

大部分抄上面的呵呵！也有不同处请试试！
呵呵！奔驰三角星标志就不玩了啦！以实用至上!可以比你的好用哦！呵呵！
临时写的没写完善请指教！

(defun c:test (/ *error* blkatt
blkref my:keypress ps
set:xhq_n xhq:keypress_b xhq:keypress_=
xhq:keypress_- xhq_n_str
)
(mak_layer)
(mak_layer2)
(mak_style)
(mak_block)
(setq xhq_n (if xhq_n
(setq xhq_n (1+ xhq_n))
1
)
xhq_n_str (vl-princ-to-string xhq_n)
)
(while (not (setq ps (getpoint "\n请输入构件号引出点:"))))
(defun *error* (msg)
(entdel (entlast))
(entdel (entlast))
(princ msg)
)
(princ "\n[序号增一(+)/序号减一(-)/新序号(b)]:")
(defun set:xhq_n (/ tmp)
(setq tmp (getint "新的序号:"))
(if tmp
(setq xhq_n tmp
xhq_n_str (vl-princ-to-string xhq_n)
)
)
(princ "\n选项[序号增一(+)/序号减一(-)/新序号(b)]:")
)
(setq my:keypress "xhq")
(setq xhq:keypress_b set:xhq_n)
(defun xhq:keypress_= ()
(setq xhq_n (1+ xhq_n)
xhq_n_str (vl-princ-to-string xhq_n)
)
)
(defun xhq:keypress_- ()
(setq xhq_n (1- xhq_n)
xhq_n_str (vl-princ-to-string xhq_n)
)
)
(setq blkref
(vla-InsertBlock
(vla-get-modelspace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(vlax-3d-point '(0 0 0))
"序号球"
1
1
1
0
)
)
(setq blkatt (car (vlax-invoke blkref 'GetAttributes)))
(defun mod_xhq (p1 p2 / dist k pp)
(cond
((/= 0 (setq dist (distance p1 p2)))
(setq k (/ 2.5 dist))
(setq
pp (mapcar '- p2 (mapcar '* (mapcar '- p1 p2) (list k k k)))
)
(entmake (list '(0 . "line")
(cons 10 p1)
(cons 11 p2)
'(8 . "序号球")
)
)
(vla-put-TextString blkatt xhq_n_str)
(vla-put-insertionpoint blkref (vlax-3d-point pp))
)
)
)
(fsxm:grread_drag
'(mod_xhq ps pt)
t
)
(c:test)
(princ)
)
(defun mak_style ()
(if (not (tblsearch "style" "num_style"))
(entmake (list
'(0 . "STYLE")
'(100 . "AcDbSymbolTableRecord")
'(100
.
"AcDbTextStyleTableRecord"
)
'(2 . "NUM_STYLE")
'(70 . 0)
'(40 . 0.0)
'(41 . 0.7)
'(50 . 0.0)
'(71 . 0)
'(3 . "TSSDENG.shx")
'(4 . "HZTXT.shx")
)
)
)
)
(defun mak_layer ()
(if (not (tblsearch "layer" "序号球"))
(entmake (list
'(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord"
)
'(100
.
"AcDbLayerTableRecord"
)
'(6 . "continuous")
'(62 . 2)
'(70 . 0)
'(2 . "序号球")
)
)
)
)
(defun mak_layer2 ()
(if (not (tblsearch "layer" "序号"))
(entmake (list
'(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord"
)
'(100
.
"AcDbLayerTableRecord"
)
'(6 . "continuous")
'(62 . 6)
'(70 . 0)
'(2 . "序号")
)
)
)
)
(defun mak_block ()
(cond ((not (tblsearch "block" "序号球"))
(entmake
(list '(0 . "BLOCK")
'(2 . "序号球")
'(10 0.0 0.0 0.0)
'(70 . 2)
)
)
(entmake (list '(0 . "CIRCLE")
'(100
.
"AcDbEntity"
)
'(67 . 0)
'(8 . "序号球")
'(100 . "CIRCLE")
'(10 0.0 0.0 0.0)
'(40 . 2.5)
'(210
0.0
0.0
1.0
)
)
)
(entmake (list '(0 . "ATTDEF")
'(8 . "序号")
'(10 0 0 0.0)
'(40 . 3.5)
'(1 . "A")
'(41 . 0.7)
'(7
.
"NUM_STYLE"
)
'(72 . 1)
'(3
.
"编号属性"
)
'(2 . "A")
'(70 . 0)
'(74 . 2)
)
)
(ENTMAKE '((0 . "ENDBLK")))
)
)
)

(defun c:test (/              *error*             blkatt 
               blkref              my:keypress    ps 
               set:xhq_n      xhq:keypress_b xhq:keypress_= 
               xhq:keypress_- xhq_n_str 
              ) 
  (mak_layer) 
  (mak_layer2) 
  (mak_style) 
  (mak_block) 
  (setq        xhq_n          (if xhq_n 
                    (setq xhq_n (1+ xhq_n)) 
                    1 
                  ) 
        xhq_n_str (vl-princ-to-string xhq_n) 
  ) 
  (while (not (setq ps (getpoint "\n请输入构件号引出点:")))) 
  (defun *error* (msg) 
    (entdel (entlast)) 
    (entdel (entlast)) 
    (princ msg) 
  ) 
  (princ "\n[序号增一(+)/序号减一(-)/新序号(b)]:") 
  (defun set:xhq_n (/ tmp) 
    (setq tmp (getint "新的序号:")) 
    (if        tmp 
      (setq xhq_n     tmp 
            xhq_n_str (vl-princ-to-string xhq_n) 
      ) 
    ) 
    (princ "\n选项[序号增一(+)/序号减一(-)/新序号(b)]:") 
  ) 
  (setq my:keypress "xhq") 
  (setq xhq:keypress_b set:xhq_n) 
  (defun xhq:keypress_=        () 
    (setq xhq_n            (1+ xhq_n) 
          xhq_n_str (vl-princ-to-string xhq_n) 
    ) 
  ) 
  (defun xhq:keypress_-        () 
    (setq xhq_n            (1- xhq_n) 
          xhq_n_str (vl-princ-to-string xhq_n) 
    ) 
  ) 
  (setq        blkref 
         (vla-InsertBlock 
           (vla-get-modelspace 
             (vla-get-ActiveDocument (vlax-get-acad-object)) 
           ) 
           (vlax-3d-point '(0 0 0)) 
           "序号球" 
           1 
           1 
           1 
           0 
         ) 
  ) 
  (setq blkatt (car (vlax-invoke blkref 'GetAttributes))) 
  (defun mod_xhq (p1 p2 / dist k pp) 
    (cond 
      ((/= 0 (setq dist (distance p1 p2))) 
       (setq k (/ 2.5 dist)) 
       (setq 
         pp (mapcar '- p2 (mapcar '* (mapcar '- p1 p2) (list k k k))) 
       ) 
       (entmake        (list '(0 . "line") 
                      (cons 10 p1) 
                      (cons 11 p2) 
                      '(8 . "序号球") 
                ) 
       ) 
       (vla-put-TextString blkatt xhq_n_str) 
       (vla-put-insertionpoint blkref (vlax-3d-point pp)) 
      ) 
    ) 
  ) 
  (fsxm:grread_drag 
    '(mod_xhq ps pt) 
    t 
  ) 
  (c:test) 
  (princ) 
) 
(defun mak_style () 
  (if (not (tblsearch "style" "num_style")) 
    (entmake (list 
               '(0 . "STYLE") 
               '(100 . "AcDbSymbolTableRecord") 
               '(100 
                 . 
                 "AcDbTextStyleTableRecord" 
                ) 
               '(2 . "NUM_STYLE") 
               '(70 . 0) 
               '(40 . 0.0) 
               '(41 . 0.7) 
               '(50 . 0.0) 
               '(71 . 0) 
               '(3 . "TSSDENG.shx") 
               '(4 . "HZTXT.shx") 
             ) 
    ) 
  ) 
) 
(defun mak_layer () 
  (if (not (tblsearch "layer" "序号球")) 
    (entmake (list 
               '(0 . "LAYER") 
               '(100 
                 . 
                 "AcDbSymbolTableRecord" 
                ) 
               '(100 
                 . 
                 "AcDbLayerTableRecord" 
                ) 
               '(6 . "continuous") 
               '(62 . 2) 
               '(70 . 0) 
               '(2 . "序号球") 
             ) 
    ) 
  ) 
) 
(defun mak_layer2 () 
  (if (not (tblsearch "layer" "序号")) 
    (entmake (list 
               '(0 . "LAYER") 
               '(100 
                 . 
                 "AcDbSymbolTableRecord" 
                ) 
               '(100 
                 . 
                 "AcDbLayerTableRecord" 
                ) 
               '(6 . "continuous") 
               '(62 . 6) 
               '(70 . 0) 
               '(2 . "序号") 
             ) 
    ) 
  ) 
) 
(defun mak_block () 
  (cond        ((not (tblsearch "block" "序号球")) 
         (entmake 
           (list '(0 . "BLOCK") 
                 '(2 . "序号球") 
                 '(10 0.0 0.0 0.0) 
                 '(70 . 2) 
           ) 
         ) 
         (entmake (list        '(0 . "CIRCLE") 
                        '(100 
                          . 
                          "AcDbEntity" 
                         ) 
                        '(67 . 0) 
                        '(8 . "序号球") 
                        '(100 . "CIRCLE") 
                        '(10 0.0 0.0 0.0) 
                        '(40 . 2.5) 
                        '(210 
                          0.0 
                          0.0 
                          1.0 
                         ) 
                  ) 
         ) 
         (entmake (list        '(0 . "ATTDEF") 
                        '(8 . "序号") 
                        '(10 0 0 0.0) 
                        '(40 . 3.5) 
                        '(1 . "A") 
                        '(41 . 0.7) 
                        '(7 
                          . 
                          "NUM_STYLE" 
                         ) 
                        '(72 . 1) 
                        '(3 
                          . 
                          "编号属性" 
                         ) 
                        '(2 . "A") 
                        '(70 . 0) 
                        '(74 . 2) 
                  ) 
         ) 
         (ENTMAKE '((0 . "ENDBLK"))) 
        ) 
  ) 
)

grread_drag请下载

Dallas_whu · 发表于 2006-11-8 23:46:49

fsxm兄果然厉害，够精练，值得学习。^_^

kohi · 发表于 2006-11-10 02:46:15

[php]
试试着个：
(defun c:test ()
  (if sn (setq sn (1+ sn))(setq sn 1))
  (setq th (* (getvar "dimtxt")(getvar "dimscale")))
  (setq A (rtos (* (getvar "CDATE") 1E8)))
  (vl-cmdf "circle" '(0 0) th "")
  (vl-cmdf "block" A '(0 0) (entlast) "")
  (vl-cmdf "insert" A '(0 0) "" "" "")
  (setq blk (entlast))
  (addatttoblock blk th "Value" '(0 0) "T1" sn)
  (setq ccobj (vlax-ename->vla-object (entlast)))
  (setq loop t)
  (prompt "\nPick Start Point:")
  (while loop
(setq p (grread T))
(setq k (car p)
   p (cadr p))
(if (= k 3)(setq loop nil))
(vla-put-insertionpoint ccobj (vlax-3d-point p))
  )
  (setq nlist p loop t)
  (while loop
(setq p1 (list (caddr (reverse nlist))(cadr (reverse nlist))(last nlist)))
(setq p (grread T))
(setq k (car p))
(setq p (cadr p))
(if (= k 3)(setq nlist (append nlist p)))
(if (= k 25)(setq loop nil))
(vla-put-insertionpoint ccobj (vlax-3d-point p))
(setq p2 (polar p (angle p p1) th))
(if (null leobj)
   (progn
(command "leader" p1 p2 "" "" "n")
(setq leobj (vlax-ename->vla-object (entlast)))
   )
);if
(prompt "\nPick Next Point:")
(setq sl (vlax-make-safearray vlax-vbDouble (cons 0 (+ 2 (length nlist)))))
(setq sa (vlax-safearray-fill sl (setq sa (append nlist p2))))
(vla-put-coordinates leobj sa)
  );w
)
(defun addatttoblock (blk h prom ptatt tag v)
  (setq doc (vla-get-activedocument (vlax-get-acad-object))
      obj (vlax-ename->vla-object blk)
   ptblk (vlax-safearray->list
         (vlax-variant-value (vla-get-insertionpoint obj)))
   blkdef (vla-item (vla-get-blocks doc)(vla-get-name obj)))
  (setq ptatt (vlax-3d-point (mapcar '- ptatt ptblk))
   attdef (vla-addattribute blkdef h acAttributeModeverify prom ptatt tag v))
  (vla-put-alignment attdef 10)
  (vla-put-textalignmentpoint attdef ptatt)
  (setq blkref (vla-insertblock
         (if (or (= (getvar "TILEMODE") 1)(> (getvar "CVPORT") 1))
   (vla-get-modelspace doc)
   (vla-get-paperspace doc)
   )
         (vlax-3d-point ptblk)
         (vla-get-name blkdef)
         (vla-get-xscalefactor obj)(vla-get-yscalefactor obj)(vla-get-zscalefactor obj)
               (vla-get-rotation obj)))
  (vla-delete obj)
  (princ)
)
[/php]

dwg001 · 发表于 2006-11-10 13:18:48

最初由 fsxm 发布
[B]大部分抄上面的呵呵！也有不同处请试试！
呵呵！奔驰三角星标志就不玩了啦！以实用至上!可以比你的好用哦！呵呵！
临时写的没写完善请指教！
[code]
(defun c:test (/ *error* blkatt
blkre... [/B]

命令: test
请输入构件号引出点:
[序号增一(+)/序号减一(-)/新序号(b)]:no function definition: FSXM:GRREAD_DRAG
命令:

fsxm · 发表于 2006-11-10 20:43:27

dwg001 老兄你好！请细看程序下面的一行字：“grread_drag请下载”
请在下面下载动态支持fsxm:grread_drag函数！

Dallas_whu · 发表于 2006-11-10 22:14:41

序号球第二版，增加少许功能！

1、支持序号球比例实时更改；
2、支持编号前缀；
3、支持编号加减；
4、保存数据改用Vl-ldata-**函数；

不支持一触即发功能！请各位指点！

;;属性序号球 BY HB.LEE 2006-11-10；
(PRINC "\n*** 带属性序号球绘制, 命令: GJ . BY HB.Lee 2006-11-10. ***")
(Defun C:GJ (/ Actdoc Addor Attball Att_Bl Att_Gjh Att_Pref
Att_Str Def_Gjh Firstpt Gjbl Gj_Id I Insertpt Mspace
Oldcmd Oldcurs Oldlay Oldos Pref Startpt Att_Addor
)
(Vl-Load-Com)
;;错误处理函数
(Defun *$Myerror$* (Msg)
(Redraw)
(Setvar "Osmode" Oldos)
(Setvar "Clayer" Oldlay)
(Setvar "Cursorsize" Oldcurs)
;;确保出错时插入的块能删除
(If Attball (Vla-Delete Attball))
(Setvar "Cmdecho" Oldcmd)
(Setq *Error* &Olderr&)
(Princ "*取消*")
(Princ)
)
(Setq &Olderr& *Error*)
(Setq *Error* *$Myerror$*)
(Setq Actdoc (Vla-Get-Activedocument (Vlax-Get-Acad-Object)))
(Setq Mspace (Vla-Get-Modelspace Actdoc))
(Setq Oldlay (Getvar "Clayer"))
(Setq Oldos (Getvar "Osmode"))
(Setq Oldcmd (Getvar "Cmdecho"))
(Setq Oldcurs (Getvar "Cursorsize"))
(Setvar "Cmdecho" 0)
(Vla-Startundomark Actdoc)
(Setq Gj_Id T)
;;捕捉方式设定
(Setvar "Osmode" (+ 1 2 32 128 512))
(While Gj_Id
(Initget 128 "P C S B")
;;设置初始比例
(Setq Gjbl (Vlax-Ldata-Get "Attball" "Gjbl"))
(If (Not Gjbl) (Setq Gjbl (Rtos (Getvar "Dimscale") 2 2)))
;;设置编号前缀
(Setq Pref (Vlax-Ldata-Get "Attball" "Prefix"))
(If (OR (= "" Pref) (= NIL Pref))
(Progn (Setq Pref "") (Princ "\n当前编号无前缀!"))
(Princ (Strcat "\n当前编号前缀:" Pref))
)
;;设置序号递增或递减,默认递增
(Setq Addor (Vlax-Ldata-Get "Attball" "Addor"))
(If (AND ADDOR (= Addor "N"))
(Princ " 序号递减!")
(PROGN (Princ " 序号递增!") (SETQ Addor "Y"))
)
(Setq Att_Addor Addor)
;;改变序号
(Setq Def_Gjh (Vlax-Ldata-Get "Attball" "Gjh_N"))
(If (Not Def_Gjh) (Setq Def_Gjh "1"))
;;设置默认字符串
(Setq Att_Str (Strcat Pref Def_Gjh))
(Setq Att_Gjh Def_Gjh)
(Setq Att_Bl (Atof Gjbl))
(Setq Att_Pref Pref)
(Setq Startpt
(Getpoint
(Strcat
"\n输入构件号引出点或[改绘图比例(S)/改编号前缀(P)/递增或递减(C)/改当前序号(B)]<"
Att_Str
">:"
)
)
)
(Cond
;;设置初始比例
((Or (= Startpt "S") (= Startpt "s"))
(Setq Att_Bl (Getreal (Strcat "\n请输入新的绘图比例<" Gjbl ">:")))
(If (Not Att_Bl) (Setq Att_Bl (Atof Gjbl)))
(Vlax-Ldata-Put "Attball" "Gjbl" (Rtos Att_Bl 2 2))
)
;;设置编号前缀
((Or (= Startpt "P") (= Startpt "p"))
(IF (= "" PREF)
(Setq Att_Pref (Getstring (Strcat "\n若需前缀,请输入编号前缀:")))
(Setq Att_Pref (Getstring (Strcat "\n若需前缀,请输入编号前缀<" Pref ">:")))
)
(If (Not Att_Pref) (Setq Att_Pref Nil))
(Vlax-Ldata-Put "Attball" "Prefix" Att_Pref)
)
;;设置序号递增或递减,默认递增
((Or (= Startpt "C") (= Startpt "c"))
(Setq Att_Addor (Getstring (Strcat "\n序号是否按顺序递增<" Addor ">:")))
(If (/= (Strcase Att_Addor) "N") (Setq Att_Addor "Y"))
(Vlax-Ldata-Put "Attball" "Addor" (Strcase Att_Addor))
)
;;改当前序号
((Or (= Startpt "B") (= Startpt "b"))
(Setq Att_Gjh
(Getint
(Strcat "\n请输入新的序号[当前默认序号<" Def_Gjh ">]:")
)
)
(Vlax-Ldata-Put "Attball" "Gjh_N" (Itoa Att_Gjh))
(If (Not Att_Gjh)
(Setq Att_Str (Strcat Pref Def_Gjh))
(Setq Att_Str (Strcat Pref (Itoa Att_Gjh)))
)
)
;;得到坐标，设置插入点
((= (Type Startpt) 'List)
(If (Null (Tblobjname "Block" (Strcat "Lhb_No_" Att_Pref)))
(Progn
(Entmake_Att 2.5 Att_Str Att_Pref)
(Entdel (Entlast))
)
)
(Setq Insertpt (Vlax-3d-Point (Polar Startpt 0 (* Att_Bl 2.5))))
(Setq Attball (Vla-Insertblock Mspace Insertpt (Strcat "Lhb_No_" Att_Pref)
Att_Bl
Att_Bl
1
0
)
)
(Foreach I (Vlax-Safearray->List
(Vlax-Variant-Value
(Vla-Getattributes Attball)
)
)
(Vla-Put-Textstring I Att_Str) ;属性值
(Vla-Put-Tagstring I Att_Str) ;标签
(If (> (Strlen Att_Str) 2) (Vla-Put-Scalefactor I 0.5)
)
)
;;动态预览
(View_Gj Attball Startpt Att_Bl)
(Setq Attball Nil)
;;序号递增或递减
(If (/= (Strcase Att_Addor) "N")
(Progn
(Setq Def_Gjh (Itoa (1+ (Atoi Def_Gjh))))
(Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh)
)
(Progn
(Setq Def_Gjh (Itoa (1- (Atoi Def_Gjh))))
(If (< (Atoi Def_Gjh) 0)
(Progn (Setq Def_Gjh "0")
(Princ "\n*** 编号不能为负数! ***")
)
)
(Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh)
)
); END IF
) ; End TYPE
;;动态预览
(View_Gj Attball Startpt Att_Bl)
(Setq Attball Nil)
;;序号递增或递减
(If (/= (Strcase Att_Addor) "N")
(Progn
(Setq Def_Gjh (Itoa (1+ (Atoi Def_Gjh))))
(Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh)
)
(Progn
(Setq Def_Gjh (Itoa (1- (Atoi Def_Gjh))))
(If (< (Atoi Def_Gjh) 0)
(Progn (Setq Def_Gjh "0")
(Princ "\n*** 编号不能为负数! ***")
)
)
(Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh)
)
) ;End Type
(T (Setq Gj_Id Nil) (PRINC "\n无效的选择或者输入!请重新确认."))
)
)
(Setvar "Clayer" Oldlay)
(Setvar "Cursorsize" Oldcurs)
(Vla-Endundomark Actdoc)
(Setvar "Osmode" Oldos)
(Setvar "Cmdecho" Oldcmd)
(Setq *Error* &Olderr&)
(Princ)
)
;;;构件编号动态预览
(DEFUN VIEW_GJ (VOBJ VBASEPT VBL / DIST FIRSTPT
LOOP_ID NEWCENPT PT1 PT10 PT11
PT12 PT2 PT3 PT4 PT5 PT6
PT7 PT8 PT9 VANGLE VPOINT VPOINTENT
MOVEPT)
(SETQ LOOP_ID T)
(SETQ ALPHA 0)
(SETVAR "CURSORSIZE" 1) ;将光标大小设置为1，最小尺寸
(PRINC "\n请输入构件号标注点:")
(WHILE LOOP_ID
(SETQ VPOINTENT (GRREAD T 4 1))
(IF (= 5 (CAR VPOINTENT)) ;鼠标跟踪
(PROGN
(REDRAW)
(SETQ VPOINT (CADR VPOINTENT))
(SETQ MOVEPT VPOINT) ;记录直线第二点
(SETQ DIST (DISTANCE VBASEPT VPOINT))
(SETQ VANGLE (ANGLE VBASEPT VPOINT))
(SETQ NEWCENPT (POLAR VBASEPT VANGLE (+ DIST (* VBL 2.5))))
(SETQ FIRSTPT (Vlax-3d-Point NEWCENPT))
(VLA-PUT-INSERTIONPOINT VOBJ FIRSTPT)
(GRVECS (LIST 2 VBASEPT VPOINT))
;;================================================================
;;动态旋转“奔驰”标志,此段可去掉，纯属好玩。
;;标注点标志
(SETQ PT1 (POLAR VPOINT (+ ALPHA (* PI 0.5)) (* VBL 1.0))
PT2 (POLAR VPOINT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0))
PT3 (POLAR VPOINT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0))
PT4 (POLAR VPOINT (+ ALPHA (/ (* PI 5) 6)) (* VBL 0.268))
PT5 (POLAR VPOINT (+ ALPHA (* PI 1.5)) (* VBL 0.268))
PT6 (POLAR VPOINT (+ ALPHA (/ PI 6)) (* VBL 0.268))
)
(GRVECS (LIST 1 PT1 VPOINT 1 PT2 VPOINT
1 PT3 VPOINT 6 PT4 VPOINT
6 PT5 VPOINT 6 PT6 VPOINT
6 PT1 PT4 6 PT4 PT2 6
PT2 PT5 6 PT5 PT3 6 PT3
PT6 6 PT6 PT1)
)
;;引出点标志
(SETQ PT7 (POLAR VBASEPT (+ ALPHA (* PI 0.5)) (* VBL 1.0))
PT8 (POLAR VBASEPT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0))
PT9 (POLAR VBASEPT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0))
PT10 (POLAR VBASEPT (+ ALPHA (/ (* PI 5) 6)) (* VBL 0.268))
PT11 (POLAR VBASEPT (+ ALPHA (* PI 1.5)) (* VBL 0.268))
PT12 (POLAR VBASEPT (+ ALPHA (/ PI 6)) (* VBL 0.268))
)
(GRVECS (LIST 1 PT7 VBASEPT 1 PT8
VBASEPT 1 PT9 VBASEPT
5 PT10 VBASEPT 5 PT11
VBASEPT 5 PT12 VBASEPT
5 PT7 PT10 5 PT10 PT8
5 PT8 PT11 5 PT11 PT9
5 PT9 PT12 5 PT12 PT7)
)
;;设置三角星旋转速度，若想加快可将0.056适当加大，如0.112.
(SETQ ALPHA (+ ALPHA (* PI 0.084)))
;;================================================================
)
)
;; 若点击鼠标左、右键或键盘任意按键，则取得当前鼠标位置，并绘制符号
(IF (OR (= 3 (CAR VPOINTENT))
(= 2 (CAR VPOINTENT))
(= 11 (CAR VPOINTENT))
)
(PROGN
(REDRAW)
(SETQ LOOP_ID NIL)
;;绘制直线
(SETVAR "CLAYER" "构件符号")
(SETQ STARTPT (Vlax-3d-Point VBASEPT))
(SETQ ENDPT (Vlax-3d-Point MOVEPT))
(VLA-ADDLINE MSPACE STARTPT ENDPT)
)
)
) ;END WHILE
(SETVAR "CURSORSIZE" OLDCURS)
(PRINC)
) ;DEFUN VIEW_GJ
;;建立属性编号
(DEFUN ENTMAKE_ATT (CIRRAD TEXT PREFIX / CHK_LAYER CHK_STYLE BLKNAME BLKN LST0
LST1)
;;建立编号圆圈图层
(SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件符号"))
(IF (= CHK_LAYER NIL)
(PROGN
(ENTMAKE (LIST
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(6 . "continuous") ;线型
'(62 . 2) ;颜色
'(70 . 0) ;图层状态
(CONS 2 "构件符号") ;图层名
)
)
)
)
;;建立编号文字图层
(SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件编号"))
(IF (= CHK_LAYER NIL)
(PROGN
(ENTMAKE (LIST
'(0 . "LAYER")
'(100
.
"AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(6 . "continuous") ;线型
'(62 . 6) ;颜色
'(70 . 0) ;图层状态
'(2 . "构件编号") ;图层名
)
)
)
)
;;建立编号文字字型
(SETQ CHK_STYLE (TBLSEARCH "STYLE" "NUM_STYLE"))
(IF (= CHK_STYLE NIL)
(ENTMAKE (LIST
'(0 . "STYLE") ;对象名称
'(100 . "AcDbSymbolTableRecord")
'(100
.
"AcDbTextStyleTableRecord") ;子类标记
'(2 . "NUM_STYLE") ;字体样式名
'(70 . 0) ;标注位码
'(40 . 0.0) ;文字高度
'(41 . 0.7) ;宽度系数
'(50 . 0.0) ;字斜角
'(71 . 0) ;文字生成标注位码2＝反向，4＝颠倒
'(3 . "TSSDENG.shx") ;西文字体名
'(4 . "HZTXT.shx") ;中文字体名
) ;_ 结束LIST
) ;_ 结束ENTMAKE
) ;_ 结束IF
;;设置属性块名
(SETQ BLKNAME (Strcat "Lhb_No_" PREFIX))
(ENTMAKE
(LIST '(0 . "BLOCK")
(CONS 2 BLKNAME) ;图块名称
'(70 . 2) ;设置属性块是否可以编辑
'(10 0.0 0.0 0.0)) ;基准点
)
(ENTMAKE (LIST '(0 . "CIRCLE")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "构件符号") ;图层名称
'(100 . "CIRCLE")
'(10 0.0 0.0 0.0) ;中心点
(CONS 40 CIRRAD) ;半径
'(210 0.0 0.0 1.0)
)
)
(ENTMAKE (LIST '(0 . "ATTDEF")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "构件编号") ;图层名称
'(100 . "AcDbText")
'(10 -1.08 -1.75 0.0) ;文字起点
(CONS 40 (+ CIRRAD 1.0)) ;文字高度
'(1 . "A") ;默认值
'(50 . 0) ;文字旋转
'(41 . 0.7) ;相对X比例系数
'(51 . 0.0) ;倾斜角度
'(7 . "NUM_STYLE") ;文字字型
'(71 . 0) ;文字产生的标志
'(72 . 1) ;水平文字的对齐类型
'(11 0.0 0.0 0.0) ;对齐点，只有在72与74非0才有意义
'(210 0.0 0.0 1.0) ;挤出方向
'(100 . "AcDbAttributeDefinition")
'(3 . "编号属性") ;提示字符串
'(2 . "A") ;卷标字符串
'(70 . 0) ;属性标志
'(73 . 0) ;字段长度
'(74 . 2) ;垂直文字的对齐类型
)
)
(SETQ BLKN (ENTMAKE '((0 . "ENDBLK"))))
(SETQ LST0 (LIST '(0 . "INSERT") '(100 . "AcDbEntity") '(67 . 0)
'(8 . "构件符号") ;图层
'(100 . "AcDbBlockReference") '(66 . 1) '(10 0.0 0.0 0.0)
;插入点
'(41 . 1.0) ;x
'(42 . 1.0) ;y
'(43 . 1.0) ;z
'(50 . 0.0) ;旋转角度
'(70 . 0) ;插入行数
'(71 . 0) ;插入列数
'(44 . 0.0) ;行间距
'(45 . 0.0) ;列间距
'(210 0.0 0.0 1.0))
)
(SETQ LST1 (APPEND LST0 (LIST (CONS 2 BLKN))))
(ENTMAKE LST1)
(ENTMAKE (LIST '(0 . "ATTRIB")
'(5 . "26")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "构件编号") ;图层名称
'(100 . "AcDbText")
'(10 -1.08 -1.75 0.0) ;文字起点
(CONS 40 (+ CIRRAD 1.0)) ;文字高度
(CONS 1 TEXT) ;默认值
'(50 . 0) ;文字旋转
'(41 . 0.7) ;相对X比例系数
'(51 . 0.0) ;倾斜角度
'(7 . "NUM_STYLE") ;文字字型
'(71 . 0) ;文字产生的标志
'(72 . 1) ;水平文字的对齐类型
'(11 0.0 0.0 0.0) ;对齐点，只有在72与74非0才有意义
'(210 0.0 0.0 1.0) ;挤出方向
'(100 . "AcDbAttribute")
(CONS 2 TEXT) ;卷标字符串
'(70 . 0) ;属性标志
'(73 . 0) ;字段长度
'(74 . 2) ;垂直文字的对齐类型
)
)
(ENTMAKE '((0 . "SEQEND")))
(PRINC)
)

;;属性序号球  BY HB.LEE 2006-11-10； 
(PRINC "\n*** 带属性序号球绘制, 命令: GJ . BY HB.Lee  2006-11-10. ***") 
(Defun C:GJ  (/  Actdoc  Addor  Attball Att_Bl Att_Gjh  Att_Pref 
                  Att_Str Def_Gjh  Firstpt  Gjbl Gj_Id  I  Insertpt  Mspace 
                  Oldcmd  Oldcurs  Oldlay  Oldos  Pref  Startpt Att_Addor 
               ) 
    (Vl-Load-Com) 
    ;;错误处理函数 
    (Defun *$Myerror$*        (Msg) 
        (Redraw) 
        (Setvar "Osmode" Oldos) 
        (Setvar "Clayer" Oldlay) 
        (Setvar "Cursorsize" Oldcurs) 
        ;;确保出错时插入的块能删除 
        (If Attball (Vla-Delete Attball)) 
        (Setvar "Cmdecho" Oldcmd) 
        (Setq *Error* &Olderr&) 
        (Princ "*取消*") 
        (Princ) 
        ) 
    (Setq &Olderr& *Error*) 
    (Setq *Error* *$Myerror$*) 
    (Setq Actdoc (Vla-Get-Activedocument (Vlax-Get-Acad-Object))) 
    (Setq Mspace (Vla-Get-Modelspace Actdoc)) 
    (Setq Oldlay (Getvar "Clayer")) 
    (Setq Oldos (Getvar "Osmode")) 
    (Setq Oldcmd (Getvar "Cmdecho")) 
    (Setq Oldcurs (Getvar "Cursorsize")) 
    (Setvar "Cmdecho" 0) 
    (Vla-Startundomark Actdoc) 
    (Setq Gj_Id T) 
    ;;捕捉方式设定 
    (Setvar "Osmode" (+ 1 2 32 128 512)) 
    (While Gj_Id 
        (Initget 128 "P C S B") 
        ;;设置初始比例 
        (Setq Gjbl (Vlax-Ldata-Get "Attball" "Gjbl")) 
        (If (Not Gjbl) (Setq Gjbl (Rtos (Getvar "Dimscale") 2 2))) 
        ;;设置编号前缀 
        (Setq Pref (Vlax-Ldata-Get "Attball" "Prefix")) 
        (If (OR (= "" Pref) (= NIL Pref)) 
            (Progn (Setq Pref "") (Princ "\n当前编号无前缀!")) 
            (Princ (Strcat "\n当前编号前缀:" Pref)) 
            ) 
        ;;设置序号递增或递减,默认递增 
        (Setq Addor (Vlax-Ldata-Get "Attball" "Addor")) 
        (If (AND ADDOR (= Addor "N")) 
          (Princ "   序号递减!") 
          (PROGN (Princ "   序号递增!") (SETQ Addor "Y")) 
        ) 
        (Setq Att_Addor Addor) 
        ;;改变序号 
        (Setq Def_Gjh (Vlax-Ldata-Get "Attball" "Gjh_N")) 
        (If (Not Def_Gjh) (Setq Def_Gjh "1")) 
 
        ;;设置默认字符串 
        (Setq Att_Str (Strcat Pref Def_Gjh)) 
        (Setq Att_Gjh Def_Gjh) 
        (Setq Att_Bl (Atof Gjbl)) 
        (Setq Att_Pref Pref) 
        (Setq Startpt 
                 (Getpoint 
                     (Strcat 
                         "\n输入构件号引出点或[改绘图比例(S)/改编号前缀(P)/递增或递减(C)/改当前序号(B)]<" 
                         Att_Str 
                         ">:" 
                         ) 
                     ) 
              ) 
        (Cond 
            ;;设置初始比例 
            ((Or (= Startpt "S") (= Startpt "s")) 
             (Setq Att_Bl (Getreal (Strcat "\n请输入新的绘图比例<" Gjbl ">:"))) 
             (If (Not Att_Bl) (Setq Att_Bl (Atof Gjbl))) 
             (Vlax-Ldata-Put "Attball" "Gjbl" (Rtos Att_Bl 2 2)) 
             ) 
            ;;设置编号前缀 
            ((Or (= Startpt "P") (= Startpt "p")) 
             (IF (= "" PREF) 
               (Setq Att_Pref (Getstring (Strcat "\n若需前缀,请输入编号前缀:"))) 
               (Setq Att_Pref (Getstring (Strcat "\n若需前缀,请输入编号前缀<" Pref ">:"))) 
             ) 
             (If (Not Att_Pref) (Setq Att_Pref Nil)) 
             (Vlax-Ldata-Put "Attball" "Prefix" Att_Pref) 
             ) 
            ;;设置序号递增或递减,默认递增 
            ((Or (= Startpt "C") (= Startpt "c")) 
             (Setq Att_Addor (Getstring (Strcat "\n序号是否按顺序递增<" Addor ">:"))) 
             (If (/= (Strcase Att_Addor) "N") (Setq Att_Addor "Y")) 
             (Vlax-Ldata-Put "Attball" "Addor" (Strcase Att_Addor)) 
             ) 
 
            ;;改当前序号 
            ((Or (= Startpt "B") (= Startpt "b")) 
             (Setq Att_Gjh 
                      (Getint 
                          (Strcat "\n请输入新的序号[当前默认序号<" Def_Gjh ">]:") 
                          ) 
                   ) 
             (Vlax-Ldata-Put "Attball" "Gjh_N" (Itoa Att_Gjh)) 
             (If (Not Att_Gjh) 
                 (Setq Att_Str (Strcat Pref Def_Gjh)) 
                 (Setq Att_Str (Strcat Pref (Itoa Att_Gjh))) 
                 ) 
             ) 
            ;;得到坐标，设置插入点 
            ((= (Type Startpt) 'List) 
             (If (Null (Tblobjname "Block" (Strcat "Lhb_No_" Att_Pref))) 
                (Progn 
                  (Entmake_Att 2.5 Att_Str Att_Pref) 
                  (Entdel (Entlast)) 
                ) 
             ) 
             (Setq Insertpt (Vlax-3d-Point (Polar Startpt 0 (* Att_Bl 2.5)))) 
             (Setq Attball (Vla-Insertblock Mspace Insertpt (Strcat "Lhb_No_" Att_Pref) 
                             Att_Bl 
                             Att_Bl 
                             1 
                             0 
                           ) 
             ) 
             (Foreach I (Vlax-Safearray->List 
                          (Vlax-Variant-Value 
                            (Vla-Getattributes Attball) 
                          ) 
                        ) 
               (Vla-Put-Textstring I Att_Str) ;属性值 
               (Vla-Put-Tagstring I Att_Str) ;标签 
               (If (> (Strlen Att_Str) 2) (Vla-Put-Scalefactor I 0.5) 
               ) 
             ) 
             ;;动态预览 
             (View_Gj Attball Startpt Att_Bl) 
             (Setq Attball Nil) 
             ;;序号递增或递减 
             (If (/= (Strcase Att_Addor) "N") 
                 (Progn 
                     (Setq Def_Gjh (Itoa (1+ (Atoi Def_Gjh)))) 
                     (Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh) 
                     ) 
                 (Progn 
                     (Setq Def_Gjh (Itoa (1- (Atoi Def_Gjh)))) 
                     (If (< (Atoi Def_Gjh) 0) 
                         (Progn        (Setq Def_Gjh "0") 
                                (Princ "\n***  编号不能为负数!  ***") 
                                ) 
                         ) 
                     (Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh) 
                     ) 
                 ); END IF 
             )                        ; End TYPE 
             ;;动态预览 
             (View_Gj Attball Startpt Att_Bl) 
             (Setq Attball Nil) 
             ;;序号递增或递减 
             (If (/= (Strcase Att_Addor) "N") 
                 (Progn 
                     (Setq Def_Gjh (Itoa (1+ (Atoi Def_Gjh)))) 
                     (Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh) 
                     ) 
                 (Progn 
                     (Setq Def_Gjh (Itoa (1- (Atoi Def_Gjh)))) 
                     (If (< (Atoi Def_Gjh) 0) 
                         (Progn        (Setq Def_Gjh "0") 
                                (Princ "\n***  编号不能为负数!  ***") 
                                ) 
                         ) 
                     (Vlax-Ldata-Put "Attball" "Gjh_N" Def_Gjh) 
                     ) 
             )                                ;End Type 
            (T (Setq Gj_Id Nil) (PRINC "\n无效的选择或者输入!请重新确认.")) 
            ) 
        ) 
    (Setvar "Clayer" Oldlay) 
    (Setvar "Cursorsize" Oldcurs) 
    (Vla-Endundomark Actdoc) 
    (Setvar "Osmode" Oldos) 
    (Setvar "Cmdecho" Oldcmd) 
    (Setq *Error* &Olderr&) 
    (Princ) 
    ) 
 
;;;构件编号动态预览 
(DEFUN VIEW_GJ        (VOBJ         VBASEPT VBL         /         DIST         FIRSTPT 
                 LOOP_ID NEWCENPT         PT1         PT10         PT11 
                 PT12         PT2         PT3         PT4         PT5         PT6 
                 PT7         PT8         PT9         VANGLE         VPOINT         VPOINTENT 
                 MOVEPT) 
    (SETQ LOOP_ID T) 
    (SETQ ALPHA 0) 
    (SETVAR "CURSORSIZE" 1)                ;将光标大小设置为1，最小尺寸 
    (PRINC "\n请输入构件号标注点:") 
    (WHILE LOOP_ID 
        (SETQ VPOINTENT (GRREAD T 4 1)) 
        (IF (= 5 (CAR VPOINTENT))        ;鼠标跟踪 
            (PROGN 
                (REDRAW) 
                (SETQ VPOINT (CADR VPOINTENT)) 
                (SETQ MOVEPT VPOINT)        ;记录直线第二点 
                (SETQ DIST (DISTANCE VBASEPT VPOINT)) 
                (SETQ VANGLE (ANGLE VBASEPT VPOINT)) 
                (SETQ NEWCENPT (POLAR VBASEPT VANGLE (+ DIST (* VBL 2.5)))) 
                (SETQ FIRSTPT (Vlax-3d-Point NEWCENPT)) 
                (VLA-PUT-INSERTIONPOINT VOBJ FIRSTPT) 
                (GRVECS (LIST 2 VBASEPT VPOINT)) 
                ;;================================================================ 
                ;;动态旋转“奔驰”标志,此段可去掉，纯属好玩。 
                ;;标注点标志 
                (SETQ PT1 (POLAR VPOINT (+ ALPHA (* PI 0.5)) (* VBL 1.0)) 
                      PT2 (POLAR VPOINT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0)) 
                      PT3 (POLAR VPOINT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0)) 
                      PT4 (POLAR VPOINT (+ ALPHA (/ (* PI 5) 6)) (* VBL 0.268)) 
                      PT5 (POLAR VPOINT (+ ALPHA (* PI 1.5)) (* VBL 0.268)) 
                      PT6 (POLAR VPOINT (+ ALPHA (/ PI 6)) (* VBL 0.268)) 
                      ) 
                (GRVECS        (LIST 1            PT1          VPOINT      1            PT2          VPOINT 
                              1            PT3          VPOINT      6            PT4          VPOINT 
                              6            PT5          VPOINT      6            PT6          VPOINT 
                              6            PT1          PT4        6     PT4   PT2          6 
                              PT2   PT5          6        PT5   PT3   6          PT3 
                              PT6   6          PT6        PT1) 
                        ) 
                ;;引出点标志 
                (SETQ PT7  (POLAR VBASEPT (+ ALPHA (* PI 0.5)) (* VBL 1.0)) 
                      PT8  (POLAR VBASEPT (+ ALPHA (/ (* PI 7) 6)) (* VBL 1.0)) 
                      PT9  (POLAR VBASEPT (+ ALPHA (/ (* PI 11) 6)) (* VBL 1.0)) 
                      PT10 (POLAR VBASEPT (+ ALPHA (/ (* PI 5) 6)) (* VBL 0.268)) 
                      PT11 (POLAR VBASEPT (+ ALPHA (* PI 1.5)) (* VBL 0.268)) 
                      PT12 (POLAR VBASEPT (+ ALPHA (/ PI 6)) (* VBL 0.268)) 
                      ) 
                (GRVECS        (LIST 1             PT7    VBASEPT          1         PT8 
                              VBASEPT            1           PT9          VBASEPT 
                              5             PT10   VBASEPT          5         PT11 
                              VBASEPT            5           PT12          VBASEPT 
                              5             PT7    PT10   5          PT10         PT8 
                              5             PT8    PT11   5          PT11         PT9 
                              5             PT9    PT12   5          PT12         PT7) 
                        ) 
                ;;设置三角星旋转速度，若想加快可将0.056适当加大，如0.112. 
                (SETQ ALPHA (+ ALPHA (* PI 0.084))) 
                ;;================================================================ 
                ) 
            ) 
        ;; 若点击鼠标左、右键或键盘任意按键，则取得当前鼠标位置，并绘制符号 
        (IF (OR        (= 3 (CAR VPOINTENT)) 
                (= 2 (CAR VPOINTENT)) 
                (= 11 (CAR VPOINTENT)) 
                ) 
            (PROGN 
                (REDRAW) 
                (SETQ LOOP_ID NIL) 
                ;;绘制直线 
                (SETVAR "CLAYER" "构件符号") 
                (SETQ STARTPT (Vlax-3d-Point VBASEPT)) 
                (SETQ ENDPT (Vlax-3d-Point MOVEPT)) 
                (VLA-ADDLINE MSPACE STARTPT ENDPT) 
                ) 
            ) 
        )                                ;END WHILE 
    (SETVAR "CURSORSIZE" OLDCURS) 
    (PRINC) 
    )                                        ;DEFUN VIEW_GJ 
 
;;建立属性编号 
(DEFUN ENTMAKE_ATT  (CIRRAD TEXT PREFIX / CHK_LAYER CHK_STYLE BLKNAME BLKN LST0 
                     LST1) 
    ;;建立编号圆圈图层 
    (SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件符号")) 
    (IF        (= CHK_LAYER NIL) 
        (PROGN 
            (ENTMAKE (LIST 
                         '(0 . "LAYER") 
                         '(100 . "AcDbSymbolTableRecord") 
                         '(100 . "AcDbLayerTableRecord") 
                         '(6 . "continuous") ;线型 
                         '(62 . 2)        ;颜色 
                         '(70 . 0)        ;图层状态 
                         (CONS 2 "构件符号") ;图层名 
                         ) 
                     ) 
            ) 
        ) 
 
    ;;建立编号文字图层 
    (SETQ CHK_LAYER (TBLSEARCH "LAYER" "构件编号")) 
    (IF        (= CHK_LAYER NIL) 
        (PROGN 
            (ENTMAKE (LIST 
                         '(0 . "LAYER") 
                         '(100 
                           . 
                           "AcDbSymbolTableRecord") 
                         '(100 . "AcDbLayerTableRecord") 
                         '(6 . "continuous") ;线型 
                         '(62 . 6)        ;颜色 
                         '(70 . 0)        ;图层状态 
                         '(2 . "构件编号") ;图层名 
                         ) 
                     ) 
            ) 
        ) 
 
    ;;建立编号文字字型 
    (SETQ CHK_STYLE (TBLSEARCH "STYLE" "NUM_STYLE")) 
    (IF        (= CHK_STYLE NIL) 
        (ENTMAKE (LIST 
                     '(0 . "STYLE")        ;对象名称 
                     '(100 . "AcDbSymbolTableRecord") 
                     '(100 
                       . 
                       "AcDbTextStyleTableRecord") ;子类标记 
                     '(2 . "NUM_STYLE")        ;字体样式名 
                     '(70 . 0)                ;标注位码 
                     '(40 . 0.0)        ;文字高度 
                     '(41 . 0.7)        ;宽度系数 
                     '(50 . 0.0)        ;字斜角 
                     '(71 . 0)                ;文字生成标注位码2＝反向，4＝颠倒 
                     '(3 . "TSSDENG.shx") ;西文字体名 
                     '(4 . "HZTXT.shx")        ;中文字体名 
                     ) ;_ 结束LIST 
                 ) ;_ 结束ENTMAKE 
        ) ;_ 结束IF 
    
    ;;设置属性块名 
    (SETQ BLKNAME (Strcat "Lhb_No_" PREFIX)) 
 
    (ENTMAKE 
        (LIST '(0 . "BLOCK") 
              (CONS 2 BLKNAME)                ;图块名称 
              '(70 . 2)                        ;设置属性块是否可以编辑 
              '(10 0.0 0.0 0.0))        ;基准点 
        ) 
    (ENTMAKE (LIST '(0 . "CIRCLE") 
                   '(100 . "AcDbEntity") 
                   '(67 . 0) 
                   '(8 . "构件符号")        ;图层名称 
                   '(100 . "CIRCLE") 
                   '(10 0.0 0.0 0.0)        ;中心点 
                   (CONS 40 CIRRAD)        ;半径 
                   '(210 0.0 0.0 1.0) 
                   ) 
             ) 
    (ENTMAKE (LIST '(0 . "ATTDEF") 
                   '(100 . "AcDbEntity") 
                   '(67 . 0) 
                   '(8 . "构件编号")        ;图层名称 
                   '(100 . "AcDbText") 
                   '(10 -1.08 -1.75 0.0) ;文字起点 
                   (CONS 40 (+ CIRRAD 1.0)) ;文字高度 
                   '(1 . "A")                ;默认值 
                   '(50 . 0)                ;文字旋转 
                   '(41 . 0.7)                ;相对X比例系数 
                   '(51 . 0.0)                ;倾斜角度 
                   '(7 . "NUM_STYLE")        ;文字字型 
                   '(71 . 0)                ;文字产生的标志 
                   '(72 . 1)                ;水平文字的对齐类型 
                   '(11 0.0 0.0 0.0)        ;对齐点，只有在72与74非0才有意义 
                   '(210 0.0 0.0 1.0)        ;挤出方向 
                   '(100 . "AcDbAttributeDefinition") 
                   '(3 . "编号属性")        ;提示字符串 
                   '(2 . "A")                ;卷标字符串 
                   '(70 . 0)                ;属性标志 
                   '(73 . 0)                ;字段长度 
                   '(74 . 2)                ;垂直文字的对齐类型 
                   ) 
             ) 
    (SETQ BLKN (ENTMAKE '((0 . "ENDBLK")))) 
    (SETQ LST0 (LIST '(0 . "INSERT") '(100 . "AcDbEntity") '(67 . 0) 
                     '(8 . "构件符号")        ;图层 
                     '(100 . "AcDbBlockReference") '(66 . 1) '(10 0.0 0.0 0.0) 
                                        ;插入点 
                     '(41 . 1.0)        ;x 
                     '(42 . 1.0)        ;y 
                     '(43 . 1.0)        ;z 
                     '(50 . 0.0)        ;旋转角度 
                     '(70 . 0)                ;插入行数 
                     '(71 . 0)                ;插入列数 
                     '(44 . 0.0)        ;行间距 
                     '(45 . 0.0)        ;列间距 
                     '(210 0.0 0.0 1.0)) 
          ) 
    (SETQ LST1 (APPEND LST0 (LIST (CONS 2 BLKN)))) 
    (ENTMAKE LST1) 
    (ENTMAKE (LIST '(0 . "ATTRIB") 
                   '(5 . "26") 
                   '(100 . "AcDbEntity") 
                   '(67 . 0) 
                   '(8 . "构件编号")        ;图层名称 
                   '(100 . "AcDbText") 
                   '(10 -1.08 -1.75 0.0) ;文字起点 
                   (CONS 40 (+ CIRRAD 1.0)) ;文字高度 
                   (CONS 1 TEXT)        ;默认值 
                   '(50 . 0)                ;文字旋转 
                   '(41 . 0.7)                ;相对X比例系数 
                   '(51 . 0.0)                ;倾斜角度 
                   '(7 . "NUM_STYLE")        ;文字字型 
                   '(71 . 0)                ;文字产生的标志 
                   '(72 . 1)                ;水平文字的对齐类型 
                   '(11 0.0 0.0 0.0)        ;对齐点，只有在72与74非0才有意义 
                   '(210 0.0 0.0 1.0)        ;挤出方向 
                   '(100 . "AcDbAttribute") 
                   (CONS 2 TEXT)        ;卷标字符串 
                   '(70 . 0)                ;属性标志 
                   '(73 . 0)                ;字段长度 
                   '(74 . 2)                ;垂直文字的对齐类型 
                   ) 
             ) 
    (ENTMAKE '((0 . "SEQEND"))) 
    (PRINC) 
    )

不要源码的下载编译文件！命令：GJ .

jx2008 · 发表于 2006-11-16 14:34:16

这个在别的地方已经有过了，楼主你是不是有什么改动没有啊？

好为人师 · 发表于 2006-11-24 13:47:16

附件无法下载,请检查

pxt2001 · 发表于 2007-6-14 21:41:47

Dallas_whu 大侠，之前的动态标高已经是精品，这个程序又是经典．非常感谢．

能否将初始比例设为100或者150呢，这样更符合画图实际应用．

Dallas_whu · 发表于 2007-6-14 22:44:14

源码都有了，自己改吧。
将下面代码中，(If (Not Gjbl) (Setq Gjbl (Rtos (Getvar "Dimscale") 2 2)))
改为 (If (Not Gjbl) (Setq Gjbl 100)) 或(If (Not Gjbl) (Setq Gjbl 150))
即可。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
;;设置初始比例
(Setq Gjbl (Vlax-Ldata-Get "Attball" "Gjbl"))
(If (Not Gjbl) (Setq Gjbl (Rtos (Getvar "Dimscale") 2 2)))
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

hstea · 发表于 2007-6-15 09:34:17

最初由 Dallas_whu 发布
[B]源码都有了，自己改吧。
将下面代码中，(If (Not Gjbl) (Setq Gjbl (Rtos (Getvar "Dimscale") 2 2)))
改为 (If (Not Gjbl) (Setq Gjbl 100)) 或(If (Not Gjbl) (Setq Gjbl 150))
即可。
＝＝＝＝＝＝＝＝＝＝?.. [/B]

Dallas_whu 大侠，不行啊！运行不了了。

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

[原创]：带属性序号球，有动态拖拽效果，欢迎测试使用！[源码免币] （第二版）

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

序号球第二版，增加少许功能！