【BB】引线圆圈数字递增属性块

huxu823

这是一个用于标注材料序号的小插件，如果哪位高手可以把它修改一下，使得【直线】和【数字圆圈属性块】成为一个整体就更完美了！
(PRINC "\n引线圆圈数字递增, 执行命令: BB ")
(Defun c:bb (/  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 "A")       ;属性块的标记。如果把"A"改成变量不带双引号的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)
            )
            (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 . "TSSDCHN.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)              ;0表示图元位于模型空间中
           '(8 . "符号")          ;图层名称
           '(100 . "CIRCLE")      ;
           '(10 0.0 0.0 0.0)      ;中心点
           (CONS 40 CIRRAD)       ;半径
           '(210 0.0 0.0 1.0)     ;拉伸方向（可选；默认值 = 0, 0, 1）
           )
         )
    (ENTMAKE (LIST '(0 . "ATTDEF")   ;对象类型：属性块
           '(100 . "AcDbEntity")
           '(67 . 0)                 ;0表示图元位于模型空间中
           '(8 . "编号")             ;图层名称
           '(100 . "AcDbText")
           '(10 -1.08 -1.75 0.0)     ;文字起点
           (CONS 40 (+ CIRRAD 1.0))  ;文字高度
           '(1 . "A")                ;默认值
           '(50 . 0)                 ;文字旋转角度（可选；默认值 = 0）
           '(41 . 0.7)               ;文字宽度比例
           '(51 . 0.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)        ;拉伸方向（可选；默认值 = 0, 0, 1）
           '(100 . "AcDbAttributeDefinition")
           '(3 . "编号属性")          ;提示字符串
           '(2 . "A")                ;标记字符串
           '(70 . 0)                 ;属性标记：1 = 属性不可见（不出现）；2 = 固定属性；4 = 输入属性时要求进行验证；8 = 属性为预置（插入时无提示）；
           '(73 . 0)                 ;字段长度（可选；默认值 = 0）
           '(74 . 2)                 ;文字垂直对齐类型：0 = 基线对正；1 = 底端对正；2 = 居中对正；3 = 顶端对正；
           )
         )
    (SETQ BLKN (ENTMAKE '((0 . "ENDBLK"))))   ;图元类型：ENDBLK
    (SETQ LST0 (LIST '(0 . "INSERT")          ;对象类型：插入点
             '(100 . "AcDbEntity")
             '(67 . 0)        ;0表示图元位于模型空间中
             '(8 . "符号")    ;图层
             '(100 . "AcDbBlockReference")
             '(66 . 1)        ;可变属性跟随标志（可选；默认值 = 0）；如果属性跟随标志的值为 1，则跟随插入的将是一系列属性图元，并以一个 seqend 图元终止。
             '(10 0.0 0.0 0.0);插入点
             '(41 . 1.0)      ;x（可选；默认值 = 1）
             '(42 . 1.0)      ;y（可选；默认值 = 1）
             '(43 . 1.0)      ;z（可选；默认值 = 1）
             '(50 . 0.0)      ;旋转角度（可选；默认值 = 0）
             '(70 . 0)        ;插入行数（可选；默认值 = 1）
             '(71 . 0)        ;插入列数（可选；默认值 = 1）
             '(44 . 0.0)      ;行间距（可选；默认值 = 0）
             '(45 . 0.0)      ;列间距（可选；默认值 = 0）
             '(210 0.0 0.0 1.0))  ;拉伸方向（可选；默认值 = 0, 0, 1）
      )
    (SETQ LST1 (APPEND LST0 (LIST (CONS 2 BLKN))))
    (ENTMAKE LST1)
    (ENTMAKE (LIST '(0 . "ATTRIB")  ;对象类型：属性
           '(5 . "26")
           '(100 . "AcDbEntity")
           '(67 . 0)                ;0表示图元位于模型空间中
           '(8 . "编号")            ;图层名称
           '(100 . "AcDbText")
           '(10 -1.08 -1.75 0.0)    ;文字起点
           (CONS 40 (+ CIRRAD 1.0)) ;文字高度
           '(1 . "A")               ;默认值
           ;(CONS 1 TEXT)           ;默认值
           '(50 . 0)                ;文字旋转角度
           '(41 . 0.7)              ;文字宽度比例
           '(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)       ;拉伸方向（可选；默认值 = 0, 0, 1）
           '(100 . "AcDbAttribute")
           '(2 . "A")               ;标记字符串
           ;(CONS 2 TEXT)           ;标记字符串
           '(70 . 0)                ;属性标记：1 = 属性不可见（不出现）；2 = 固定属性；4 = 输入属性时要求进行验证；8 = 属性为预置（插入时无提示）；
           '(73 . 0)                ;字段长度
           '(74 . 2)                ;文字垂直对齐类型
           )
         )
    (ENTMAKE '((0 . "SEQEND")))
    (PRINC)
    )

h2295

huxu823 发表于 2024-4-25 01:11
我用了很多年，没有问题，你是不是保存格式有误

缩进有点小问题，请问那个圆心（10，0，0，0）是不是相对坐标，这个原点的设置是在哪？可不可以将这个点设置在第二个点击点，我想把圆换成横线应该怎么改啊？

huxu823

h2295 发表于 2024-4-24 22:37
这个代码是不是有问题，稍微修改一下都报错：引线圆圈数字递增, 执行命令: BB ; 错误: 输入的列表有缺陷

我用了很多年，没有问题，你是不是保存格式有误

h2295

这个代码是不是有问题，稍微修改一下都报错：引线圆圈数字递增, 执行命令: BB ; 错误: 输入的列表有缺陷

szhorse

看着不错，感谢分享源码

paulpipi

感谢分享，同请高人帮忙

yefei812678

感谢分享感谢分享

cghdy

引线加进去就成动态块了，难度不是一个量级

rhww

很好很强大，我现在一般用探索者的

jkop

测试完发现很方便，能快速标示指出的序列号。

zhangrunze

不错~感谢分享，适合标注装配图。很方便呢~

kozmosovia

可以直接用多重引线，内置支持文字带圆圈，啥代码都不需要

huxu823

kozmosovia 发表于 2024-3-19 10:09
可以直接用多重引线，内置支持文字带圆圈，啥代码都不需要

求分享