寻找高手~动态弯道标注,修改标注单位R为米,L为米单位

song宋_74729

动态弯道标注,麻烦修改标注单位R为米,L为米单位,

谢谢

(本程序采摘自www.lisp123.com)

(defun c:WGBZ()

        (Form1_load)

)

(defun Form1_load( / dcl_id Dialog_Return key keysDcl_File)

        (vl-load-com)

        (setq dcl_id(load_dialog (setq Dcl_File (Write_Dcl_Form1))));对话框加载

        (vl-file-deleteDcl_File);加载后删除DCL文件

        (setqDialog_Return 2)

        ;(while (>Dialog_Return 1) ;循环控制对话框是否结束

                (new_dialog"Form1" dcl_id);建立窗体

;-->-->-对话框初始化->-->--

                (setq keys'("Command1" "Command2" "accept""cancel"));列表全部控件名称

                (foreach keykeys;全部控件的初始化

                        (if (eval(read (strcat key "_bak"))) (set_tile key (eval (read (strcat key"_bak")))));控件内容

                        (action_tilekey "(Action_Form1_Keys $key $value)");点击动作

                )

;--<--<-对话框初始化完成-<--<--

                (setqDialog_Return (start_dialog));开启对话框(用户可见)

                (cond

                        ((=Dialog_Return 3)

                                (cj)

                        )

                        ((=Dialog_Return 4)

                                (gdcj)

                        )

                )

        ;)

        (unload_dialogdcl_id);退出时卸除对话框

        (princ);防止函数回显

)

(defun Action_Form1_Keys (key value) ;全部控件的点击动作触发

        (cond

                ((= key"accept") ;{确认按钮}

                        (Get_Form1_Data)

                        (done_dialog1);对话框退出返回主函数 传递给Dialog_Return值为1

                )

                ((= key"cancel") ;{取消按钮}

                        (done_dialog0);对话框退出返回主函数 传递给Dialog_Return值为0

                )

                ((= key"Command1") ; {"插件名字"}(按钮)

                        (done_dialog3)

                )

                ((= key"Command2") ; {"更多插件"}(按钮)

                        (done_dialog4)

                )

        )

)

(defun Get_Form1_Data( / key);临时生成Dcl文件 返回文件名

        (foreach keykeys

                (set (read(strcat key "_bak")) (get_tile key));每个控件都赋给一个变量 用于下次开启初始化

        )

)

(defun Write_Dcl_Form1( / Dcl_File file str)

        (setqDcl_File (vl-filename-mktemp nil nil ".Dcl"))

        (setq file(open Dcl_File "w"))

        (foreach str'(

                "Form1:dialog"

                "{"

                " label= \"Lisp123出品插件\";"

                "    :row"

                "    {"

                "        :button"

                "        {"

                "            key = \"Command1\";"

                "            label = \"动态弯道标注\" ;"

                "            width = 18.15 ;"

                "            height = 1.875 ;"

                "        }"

                "    }"

                "        :button"

                "        {"

                "            key = \"Command2\";"

                "            label = \"更多插件\" ;"

                "            width = 10.95 ;"

                "            height = 1.875 ;"

                "        }"

                "ok_cancel;"

                "}"

                )

                (write-linestr file)

        )

        (close file)

        Dcl_File

)

(defun gdcj ( / )

(COMMAND "browser""http://www.Lisp123.com")

)

(defun cj ( / )

   (prompt"\n 弯道标注程序加载成功,只支持圆弧线！")

  (setqoldosmode (getvar "osmode"))

  (setq  l  (getvar "ltscale")

  scale   1.0

  textsize (*l 3.0)

  )

(vl-load-com)

  (if (and (setqen1 (entsel "\n 请选取轨道中心线弧线："))

     (setqarcobj (vlax-ename->vla-object (car en1)))

     ;;得到起点坐标

     (setqStartpt (vla-get-StartPoint arcobj))

     (setqStartpt (vlax-variant-value Startpt))

     (setqStartPoint (vlax-safearray->list Startpt))

     ;;得到终点坐标

     (setqEndpt (vla-get-EndPoint arcobj))

     (setqEndpt (vlax-variant-value Endpt))

     (setqEndPoint (vlax-safearray->list Endpt))

     ;;得到圆心坐标

     (setqCenterpt (vla-get-Center arcobj))

     (setqCenterpt (vlax-variant-value Centerpt))

     (setqCenterPoint (vlax-safearray->list Centerpt))

     ;;得到弧的夹角

     (setqtotalangle (vla-get-totalangle arcobj))

     ;;得到d-f-m

     (setqang_d (fix (/ (* totalangle 180) pi))

     ang_f(fix (* (- (/ (* totalangle 180) pi) ang_d) 60))

     ang_m(fix (* (- (/ (* totalangle 180) pi) ang_d (/ ang_f 60.0)) 3600))

     )

     ;;得到转角数

     (setqang (strcat "θ="

          (itoa ang_d)

          "°"

          (if (> ang_f 10)

            (itoa ang_f)

            (strcat "0" (itoa ang_f))

           )

          "′"

          (if (> ang_m 10)

            (itoa ang_m)

            (strcat "0" (itoa ang_m))

           )

          "〞"

         )

     )

     ;;获取半径

     (setqradius (fix (* (vla-get-radius arcobj) 1000)))

     ;;取弧长

     (setqArcLength (fix (* (vla-get-ArcLength arcobj) 1000)))

    ;;-----------------------------------------

     ;;绘制引线                                     θ

     (setqpt1 (getpoint "\n选择标注点:"))

     ;; 这个范例在模型空间中建立具有一个关系型注释的一条引线，

     ;; 接着显示新的引线的注释对象。

     (setqAcadObject   (vlax-get-acad-object)

    AcadDocument (vla-get-ActiveDocument Acadobject)

    mSpace        (vla-get-ModelSpaceAcaddocument)

     )

     ;; 定义新的 MText 对象

     (setqtextString (strcat ang "\n" (strcat "R=" (itoa radius))"\n" (strcat "L=" (itoa ArcLength))))

     (setqinsertionPnt (vlax-make-safearray vlax-vbDouble '(0 . 2)))

    (vlax-safearray-fill insertionPnt pt1)

     (setqwidth (distance (car (textbox (list (cons 1 ang)))) (cadr (textbox (list (cons1 ang))))))

     ;; 在模型空间中建立MText 对象

     (setqMTextObj (vla-AddMText mSpace insertionPnt width textString))

     ;;填满wenzi

     (setqwenzi (vlax-make-safearray vlax-vbString '(1 . 9)))

     (vlax-safearray-fill

       wenzi

      '("TopLeft" "TopCenter" "TopRight"  "MiddleLeft""MiddleCenter" "MiddleRight" "BottomLeft""BottomCenter" "BottomRight")

     )

     ;; 引线数据

     (setqpnts (vlax-make-safearray vlax-vbDouble '(0 . 5)))

    (vlax-safearray-fill pnts (append pt1 (polar pt1 0 1)))

     ;;是否显示箭头

     (setqleaderType acLineWithArrow)

     ;;设置初始箭头为"实心闭合"

     (setqArrowheadType 0)

     ;;创建箭头类型列表

     (setqArrowheadTypeList (vlax-make-safearray vlax-vbstring '(1 . 20)))

    (vlax-safearray-fill

       ArrowheadTypeList

      '("实心闭合""空心闭合""闭合""点""建筑标记""倾斜""打开""指示原点""指示原点2""直角"  "30度角" "小点" "空心点""空心小点""方框""实心方框""基准三角形""实心基准三角形""积分""无")

     )

     ;; 在模型中建立Leader 对象，接着将MText对象设成

     ;;Leader注释，使新的MText对象和新的Leader对象建立关联

     (setqannotationObject MTextObj)

     (setqleaderObj (vla-AddLeader mSpace pnts annotationObject leaderType))

     (princ"\n")

      )

    (progn(setq LST (list '(5

          (grdraw CenterPoint StartPoint 1)

          (grdraw CenterPoint EndPoint 1)

          (setq pt val)

           ;;更新文字插入点

          (vla-put-InsertionPoint MTextObj (vlax-3d-point pt))

           ;;更新文字插入点

           ;;设置文字的对齐点

          (vla-put-AttachmentPoint MTextObj acAttachmentPointBottomLeft)

           ;;修改文字颜色

          (vla-put-Color MTextObj 3)

           (vla-put-Layer MTextObj"zj")

          (vla-put-Width MTextObj width)

          (if

           (<= (car pt) (car pt1))

           ;;如果鼠标移动点的x坐标值小于等于最近点的X坐标值

           (vla-put-AttachmentPoint MTextObj 9)

           ;;更改文字的贴附点为9（右下角）

           (vla-put-AttachmentPoint MTextObj 7)

           ;;更改文字的贴附点为7（左下角）

           )

          ;;end_if

          (setq pnts1 (vlax-make-safearray vlax-vbDouble '(0 . 5)))

          (vlax-safearray-fill pnts1 (append pt1 (polar pt 0 1)))

           (vla-put-Coordinates leaderObj pnts1)

           ;;更新引线插入点

           ;;设置文字标注在上方

          (vla-put-VerticalTextPosition leaderObj acAbove)

           ;;设置文字与标注线的垂直距离

          (vla-put-TextGap leaderObj (* l 1))

           ;;设置标注线的图层

           (vla-put-layer leaderObj"zj")

           ;;设置标注线的颜色

          (vla-put-DimensionLineColor leaderObj 1)

           ;;设置初始箭头大小

          (vla-put-ArrowheadSize leaderObj scale)

          (princ "\n按加减号改变箭头大小<+/->,按 </> 键改变文字高度,按Tab键改变箭头样式:")

          )

         '(2

           ;;按TAB键

           (9

           (setq ArrowheadType (+ ArrowheadType 1))

           (if

            (> ArrowheadType 19)

            (setq ArrowheadType 0)

            )

           ;;修改箭头大小

           (vla-put-ArrowheadType leaderObj ArrowheadType)

            (princ

            (strcat

       "\n箭头变换啦***"

       " 当前箭头样式为->"

       (vlax-safearray-get-element ArrowheadTypeList (+ ArrowheadType 1))

            )

            )

           )

          (43

           (setq scale (+ scale 0.1))

           ;;修改箭头大小

            (vla-put-ArrowheadSize leaderObjscale)

           (princ (strcat "\n箭头增大啦***"" 当前比例="(rtos scale 2 1)))

           )

          (45

           (setq scale (- scale 0.1))

           ;;修改箭头大小

           (if

            (> scale 0.18)

            (progn

       (vla-put-ArrowheadSize leaderObj scale)

       (princ (strcat "\n箭头减小啦***"" 当前比例="(rtos scale 2 1)))

            )

            (princ "\n箭头已经是最小了！")

            )

           )

           ;;修改文字高度

          (44

           (setq width (* width (/ (+ textsize 0.1) textsize)))

           (setq textsize (+ textsize 0.1))

           (vla-put-Height MTextObj textsize)

           (princ (strcat "\n文字高度增大啦***"" 当前高度="(rtos textsize 2 1)))

           )

          (46

           (setq width (* width (/ (- textsize 0.1) textsize)))

           (setq textsize (- textsize 0.1))

           (vla-put-Height MTextObj textsize)

           (princ (strcat "\n文字高度减小啦***"" 当前高度="(rtos textsize 2 1)))

           )

          )

         ;;左击

         '

          (3(setq pt val)

            (initget 1 " y n Y N  ")

            (setq xunwen (getkword "\n是否绘制半径[Y/N或回车退出]:"))

             (if (or (= xunwen "y") (=xunwen "Y") (= xunwen " "))

        (progn (command "line" CenterPoint StartPoint "")(command "line" CenterPoint EndPoint ""))

            )

            (redraw)

            (setq TEST NIL)

            (setvar "osmode" oldosmode)

          )

            '(25 (redraw) (setq TEST NIL))

            '(11 (redraw) (setq TEST NIL))

          )

     )

    (ZML-GRREAD lst)

    )

  )

  (princ)

)

(defun ZML-GRREAD (LST / test tmp mode val tmp2)

  (setq testt)

  (while test

    (setqtmp  (grread 2)

    mode (cartmp)

    val  (cadr tmp)

    )

    (cond ((=mode 2)

     (if (and(setq tmp2 (assoc mode lst)) (setq tmp2 (cdr tmp2)) (setq tmp2 (assoc valtmp2)))

       (eval(cons 'progn (cdr tmp2)))

       ()

     )

    )

    ((setqtmp2 (assoc mode lst)) (eval (cons 'progn (cdr tmp2))))

    (t (princtmp))

    )

  )

)

(princ "\n本程序采摘自www.lisp123.com更多内容敬请期待！")

(princ "\n本程序命令：WGBZ")

(princ)

song宋_74729

xyp1964 发表于 2023-1-25 13:26
;; 慎用：需要e派工具箱(XCAD)的支持

能不能不要e派工具箱,也能够用

中国梦

谢谢楼主分享

xyp1964

代码错误太多，扔了吧！

song宋_74729

xyp1964 发表于 2023-1-24 18:59
代码错误太多，扔了吧！

院长有更好的吗?

xyp1964

song宋_74729 发表于 2023-1-25 10:13
院长有更好的吗?

;; 慎用：需要e派工具箱(XCAD)的支持

xyp1964

czb203

xyp1964 发表于 2023-1-26 11:31

院长一如既往的牛叉～