寻找高手~动态弯道标注,修改标注单位R为米,L为米单位
本帖最后由 song宋_74729 于 2023-1-24 10:38 编辑动态弯道标注,麻烦修改标注单位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"))(setql(getvar "ltscale")scale 1.0textsize (*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是否绘制半径或回车退出]:")) (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)
xyp1964 发表于 2023-1-25 13:26
;; 慎用：需要e派工具箱(XCAD)的支持
能不能不要e派工具箱,也能够用 谢谢楼主分享 代码错误太多，扔了吧！ xyp1964 发表于 2023-1-24 18:59
代码错误太多，扔了吧！
院长有更好的吗? song宋_74729 发表于 2023-1-25 10:13
院长有更好的吗?
;; 慎用：需要e派工具箱(XCAD)的支持
xyp1964 发表于 2023-1-26 11:31
院长一如既往的牛叉～
页:
[1]