[原创]带属性序号球，有动态拖拽效果，欢迎测试使用！

Dallas_whu · 发表于 2006-11-10 18:30:00

上传的附件哪里去了？有没有版主介绍一下发帖规则？

;;属性序号球 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)
    )

LinBinFen · 发表于 2024-4-26 10:55:42

18年前的程序效果很好，多谢分享!

mojianxing · 发表于 2024-1-9 14:00:18

效果很好的程序，多谢分享

sunny_8848 · 发表于 2020-6-14 18:47:36

效果很好的程序，多谢分享

rongyifei · 发表于 2006-11-10 22:44:00

程序文件是不是没有格式化,看起来很乱!

Dallas_whu · 发表于 2006-11-10 22:47:00

我不知道怎么帖源码？有没有版主帮帮忙？

xshrimp · 发表于 2006-11-11 00:38:00

例如

;程序主程序
(defun c:xxx()sddd)

代码前加

Dallas_whu · 发表于 2006-11-11 08:43:00

我加上[code]就变成一片混乱了，不知道是不是行数太多了？另外我传得附件不知到哪里去了？

rongyifei · 发表于 2006-11-11 20:22:00

程序很长,看来够学习阵子了,楼主辛苦了!

ctclsc · 发表于 2006-11-14 12:51:00

能不能让直线和圆、数字成为一体，并且在拖动直线端点时，使直线始终通过圆心（好像是通过反应器），谢谢。。。

Dallas_whu · 发表于 2006-11-14 22:04:00

呵呵，反应器这玩意儿还不会玩！

killer9806 · 发表于 2006-11-16 23:04:00

感谢楼主提供。

jxphklibin · 发表于 2010-7-16 04:09:00

呵呵，旧贴子了

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

[原创]带属性序号球，有动态拖拽效果，欢迎测试使用！

点评

评分

本帖子中包含更多资源