[原创]带属性序号球，有动态拖拽效果，欢迎测试使用！
上传的附件哪里去了？有没有版主介绍一下发帖规则？;;属性序号球BY HB.LEE 2006-11-10；
(PRINC "\n*** 带属性序号球绘制, 命令: GJ . BY HB.Lee2006-11-10. ***")
(Defun C:GJ(/ActdocAddorAttball Att_Bl Att_GjhAtt_Pref
Att_Str Def_GjhFirstptGjbl Gj_IdIInsertptMspace
OldcmdOldcursOldlayOldosPrefStartpt 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)
)
18年前的程序效果很好，多谢分享! 效果很好的程序，多谢分享 效果很好的程序，多谢分享 程序文件是不是没有格式化,看起来很乱! 我不知道怎么帖源码？有没有版主帮帮忙？ 例如
;程序主程序
(defun c:xxx()sddd)
代码前加
我加上就变成一片混乱了，不知道是不是行数太多了？另外我传得附件不知到哪里去了？ 程序很长,看来够学习阵子了,楼主辛苦了! 能不能让直线和圆、数字成为一体，并且在拖动直线端点时，使直线始终通过圆心（好像是通过反应器），谢谢。。。 呵呵，反应器这玩意儿还不会玩！ 感谢楼主提供。 呵呵，旧贴子了