乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 61|回复: 3

[原创]一个局部放大程序

[复制链接]
cag

87

主题

265

帖子

10

银币

中流砥柱

Rank: 25

铜币
613
发表于 2004-4-21 15:24:00 | 显示全部楼层 |阅读模式
;;;希望能起抛砖引玉的作用,能有人把放大(fd)的那一块给写下去。
(vl-load-com)
;;;(alert "\n局部放大jbfd,小金鱼2004.2.18")
(defun c:jbfd (/        *error*         mSpace                 cir                         i                                 NEXT_PT
                                                         READTYP        READVAL         basept                 line                         text                                 tzz
                                                         txtlen        l2         l2end                 cen                         pt                                 text_x
                                                         ptt        l2_x         fh                 fh1                         ss1
                                                         MakeUnNameBlock
                                                 )
         (defun *error* (msg / ent count)
                         (cond
                                         ((or (= msg "函数被取消") (= msg "Function cancelled"))
                                                 (command "_.ERASE" ss1 "")
                                         )
                                         ((= msg "ActiveX 服务器返回错误: 未知名称: Center") ;处理输入d
                                                 (alert (strcat "唉,我无法处理\"d\"错误,"
                                                         "\n如果你知道请通知我。"
                                                         "\nE_mail:cag25@sohu.com"
                                                         "\nQQ:297240086"
                                                 )
                                                 )
                                         )
                                         (T
                                                 (alert (strcat msg
                                                         "\n\n对不起,有错误产生,请通知我。"
                                                         "\nE_mail:cag25@sohu.com"
                                                         "\nQQ:297240086"
                                                 )
                                                 )
                                         )
                         )
         )
         (setq        mSpace (vla-get-ModelSpace
                 (vla-get-ActiveDocument (vlax-get-acad-object))
                                                         )
         )
         (setq ss1 (ssadd))
         (defun MakeUnNameBlock (ss pt / count entlist ent blk)
                         (entmake (list '(0 . "BLOCK")
                                 '(2 . "*U")
                                 '(70 . 1)
                                 (cons 10 pt)
                                         )
                         )
                         (setq count 0)
                         (repeat (sslength ss)
                                         (setq entlist (entget (setq ent (ssname ss count))))
                                         (setq count (1+ count))
                                         (entmake entlist)
                         )
                         (setq count 0)
                         (repeat (sslength ss)
                                         (setq ent (ssname ss count))
                                         (setq count (1+ count))
                                         (entdel ent)
                         )
                         (setq blk (entmake '((0 . "ENDBLK"))))
                         (if        T
                                         (entmake (list (cons 0 "INSERT")
                                                 (cons 2 blk)
                                                 (cons 10 pt)
                                                         )
                                         )
                         )
         )
         (defun Tzz (Text / textent ang sinrot cosrot t1 t2 p0 p1 p2 p3 p4)
                         (setq textent (entget (vlax-vla-object->ename Text)))
                         (setq p0         (cdr (assoc 10 textent))
                 ang         (cdr (assoc 50 textent))
                 sinrot (sin ang)
                 cosrot (cos ang)
                 t1         (car (textbox textent))
                 t2         (cadr (textbox textent))
                 p1         (list
                                 (+ (car p0)
                                                         (- (* (car t1) cosrot) (* (cadr t1) sinrot))
                                 )
                                 (+ (cadr p0)
                                                         (+ (* (car t1) sinrot) (* (cadr t1) cosrot))
                                 )
                 )
                 p2         (list
                                 (+ (car p0)
                                                         (- (* (car t2) cosrot) (* (cadr t1) sinrot))
                                 )
                                 (+ (cadr p0)
                                                         (+ (* (car t2) sinrot) (* (cadr t1) cosrot))
                                 )
                 )
                         )
                         (distance p1 p2)
         )
         (defun fd (/ minpt maxpt ss2)
                         (vla-getboundingbox cir 'minpt 'maxpt)
                         (setq minpt        (vlax-safearray->list minpt)
                 maxpt        (vlax-safearray->list maxpt)
                         )
                         (setq ss2 (ssget "C" maxpt minpt))
                         (command "copy" ss2 "" cen)
                         (princ "\n指定放大图位置:")
                         (if (not (command pause))
                                         (MakeUnNameBlock ss1 cen)
                         )
         )
         
         (setvar "cmdecho" 0)
         (initget 1)
         (setq p1 (getpoint "\n指定放大中心点:"))
         (command "circle" p1)
         (princ
                         (strcat "\n指定放大半径 :")
         )
         (command pause)
         (setq cir (vlax-ename->vla-object (entlast)))
         (vla-put-color cir (getvar "dimclrd"))
         (vla-update cir)
         (ssadd (entlast) ss1)
         (setq        cen (vlax-safearray->list
                                                 (vlax-variant-value (vla-get-center cir))
                                 )
         )
         (setq pt (car cen))
         (princ "\n指定视图符号放置位置 :")
         (setq i T)
         (while i
                         (Setq NEXT_PT (GrRead T 4 0)
                 READTYP (car NEXT_PT)
                 READVAL (cadr NEXT_PT)
                         )
                         (cond
                                         ((= READTYP 5)                        ;移动
                                                 (setq NEXT_PT (cadr NEXT_PT))
                                                 (setq next_pt (trans next_pt 1 0))
                                                 (setq basept (vlax-curve-getclosestpointto cir NEXT_PT))
                                                 (if (not line)
         (progn
                         (if (not fh)
                                         (setq fh "A")
                         )
                         (setq text (vla-addtext
                        mspace
                        fh
                        (vlax-3d-point next_pt)
                        (getvar "dimtxt")
                                                         )
                         )
                         (vla-put-color text (getvar "dimclrt"))
                         (vla-put-stylename text (getvar "dimtxsty"))
                         (vla-update text)
                         (ssadd (entlast) ss1)
                         (setq line (vla-addline
                        mspace
                        (vlax-3d-point basept)
                        (vlax-3d-point next_pt)
                                                         )
                         )
                         (vla-put-color line (getvar "dimclrd"))
                         (ssadd (entlast) ss1)
                         (setq txtlen (tzz text))
                         (setq l2end (list (+ (car next_pt) txtlen) (cadr next_pt) 0))
                         (setq l2 (vla-addline
                                                         mspace
                                                         (vlax-3d-point next_pt)
                                                         (vlax-3d-point l2end)
                                         )
                         )
                         (vla-put-color l2 (getvar "dimclrd"))
                         (ssadd (entlast) ss1)
         )
         (progn
                         (vla-put-startpoint line (vlax-3d-point basept))
                         (vla-put-endpoint line (vlax-3d-point next_pt))
                         (vla-update line)
                         (setq ptt (car next_pt))
                         (if (> ptt pt)
                                         (progn
                                                         (setq text_x (+ (car next_pt) (getvar "dimgap")))
                                                         (setq l2_x (+ (car next_pt) txtlen (getvar "dimgap")))
                                         )
                                         (progn
                                                         (setq text_x (- (car next_pt) (getvar "dimgap") txtlen))
                                                         (setq l2_x text_x)
                                         )
                         )
                         (vla-put-insertionpoint
                                         text
                                         (vlax-3d-point
                                                         (list text_x (+ (cadr next_pt) (getvar "dimgap")) 0)
                                         )
                         )
                         (vla-update text)
                         (vla-put-startpoint l2 (vlax-3d-point next_pt))
                         (setq l2end (list l2_x (cadr next_pt) 0))
                         (vla-put-endpoint l2 (vlax-3d-point l2end))
                         (vla-update l2)
         )
                                                 )
                                         )
                                         ((= READTYP 3)                        ;左键击
;;;                                                 (MakeUnNameBlock ss1 cen)
                                                 (setq i nil)
                                         )
                                         ((or (= 25 readtyp) (= 13 READVAL)) ;回车或右键
                                                 (setq fh1 fh)
                                                 (setq fh        (getstring (strcat
                                                         "\n输入新视图符号 :"
                                         )
                )
                                                 )
                                                 (if (= fh "")
         (setq fh fh1)
                                                 )
                                                 (vla-put-textstring text fh)
                                                 (vla-update text)
                                                 (setq txtlen (tzz text))
                                                 (princ "\n指定视图符号放置位置 :")
                                         )
                         )
         )
         (fd)
         (princ)
)
回复

使用道具 举报

63

主题

1203

帖子

10

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1455
发表于 2004-4-22 17:31:00 | 显示全部楼层
這個OK        還有些地方有待改進. 將就用用先.(vl-load-com)
;;;(alert "\n局部放大jbfd,小金?2004.2.18")
(defun c:jbfd (/ *error*         mSpace                 cir                         i                                 NEXT_PT
                                                         READTYP READVAL         basept                 line                         text                                 tzz
                                                         txtlen l2         l2end                 cen                         pt                                 text_x
                                                         ptt l2_x         fh                 fh1                         ss1
                                                         MakeUnNameBlock
                                                 )
         (defun *error* (msg / ent count)
                         (cond
                                         ((or (= msg "函?被取消") (= msg "function cancelled"))
                                                 (command "_.ERASE" ss1 "")
                                         )
                                         ((= msg "ActiveX 服?器返回??: 未知名?: Center") ;?理?入d
                                                 (alert (strcat "唉,我?法?理\"d\"??,"
                                                         "\n如果你知道?通知我。"
                                                         "\nE_mail:cag25@sohu.com"
                                                         "\nQQ:297240086"
                                                 )
                                                 )
                                         )
                                         (T
                                                 (alert (strcat msg
                                                         "\n\n?不起,有???生,?通知我。"
                                                         "\nE_mail:cag25@sohu.com"
                                                         "\nQQ:297240086"
                                                 )
                                                 )
                                         )
                         )
         )
         (setq mSpace (vla-get-ModelSpace
                 (vla-get-ActiveDocument (vlax-get-acad-object))
                                                         )
         )
         (setq ss1 (ssadd))
         (defun MakeUnNameBlock (ss pt / count entlist ent blk)
                         (entmake (list '(0 . "BLOCK")
                                 '(2 . "*U")
                                 '(70 . 1)
                                 (cons 10 pt)
                                         )
                         )
                         (setq count 0)
                         (repeat (sslength ss)
                                         (setq entlist (entget (setq ent (ssname ss count))))
                                         (setq count (1+ count))
                                         (entmake entlist)
                         )
                         (setq count 0)
                         (repeat (sslength ss)
                                         (setq ent (ssname ss count))
                                         (setq count (1+ count))
                                         (entdel ent)
                         )
                         (setq blk (entmake '((0 . "ENDBLK"))))
                         (if T
                                         (entmake (list (cons 0 "INSERT")
                                                 (cons 2 blk)
                                                 (cons 10 pt)
                                                         )
                                         )
                         )
         )
         (defun Tzz (Text / textent ang sinrot cosrot t1 t2 p0 p1 p2 p3 p4)
                         (setq textent (entget (vlax-vla-object->ename Text)))
                         (setq p0         (cdr (assoc 10 textent))
                 ang         (cdr (assoc 50 textent))
                 sinrot (sin ang)
                 cosrot (cos ang)
                 t1         (car (textbox textent))
                 t2         (cadr (textbox textent))
                 p1         (list
                                 (+ (car p0)
                                                         (- (* (car t1) cosrot) (* (cadr t1) sinrot))
                                 )
                                 (+ (cadr p0)
                                                         (+ (* (car t1) sinrot) (* (cadr t1) cosrot))
                                 )
                 )
                 p2         (list
                                 (+ (car p0)
                                                         (- (* (car t2) cosrot) (* (cadr t1) sinrot))
                                 )
                                 (+ (cadr p0)
                                                         (+ (* (car t2) sinrot) (* (cadr t1) cosrot))
                                 )
                 )
                         )
                         (distance p1 p2)
         )
         
         
         (setvar "cmdecho" 0)
         (initget 1)
         (setq p1 (getpoint "\n指定放大中心?:"))
         (command "circle" p1)
         (princ
                         (strcat "\n指定放大半? :")
         )
         (command pause)
         (setq newcircle (entlast))
         (setq cir (vlax-ename->vla-object (entlast)))
         (vla-put-color cir (getvar "dimclrd"))
         (vla-update cir)
         (ssadd (entlast) ss1)
         (setq cen (vlax-safearray->list
                                                 (vlax-variant-value (vla-get-center cir))
                                 )
         )
         (setq pt (car cen))
         (princ "\n指定??符?放置位置 :")
         (setq i T)
         (while i
                         (Setq NEXT_PT (GrRead T 4 0)
                 READTYP (car NEXT_PT)
                 READVAL (cadr NEXT_PT)
                         )
                         (cond
                                         ((= READTYP 5)                 ;移?
                                                 (setq NEXT_PT (cadr NEXT_PT))
                                                 (setq next_pt (trans next_pt 1 0))
                                                 (setq basept (vlax-curve-getclosestpointto cir NEXT_PT))
                                                 (if (not line)
         (progn
                         (if (not fh)
                                         (setq fh "A")
                         )
                         (setq text (vla-addtext
                 mspace
                 fh
                 (vlax-3d-point next_pt)
                 (getvar "dimtxt")
                                                         )
                         )
                         (vla-put-color text (getvar "dimclrt"))
                         (vla-put-stylename text (getvar "dimtxsty"))
                         (vla-update text)
                         (ssadd (entlast) ss1)
                         (setq line (vla-addline
                 mspace
                 (vlax-3d-point basept)
                 (vlax-3d-point next_pt)
                                                         )
                         )
                         (vla-put-color line (getvar "dimclrd"))
                         (ssadd (entlast) ss1)
                         (setq txtlen (tzz text))
                         (setq l2end (list (+ (car next_pt) txtlen) (cadr next_pt) 0))
                         (setq l2 (vla-addline
                                                         mspace
                                                         (vlax-3d-point next_pt)
                                                         (vlax-3d-point l2end)
                                         )
                         )
                         (vla-put-color l2 (getvar "dimclrd"))
                         (ssadd (entlast) ss1)
         )
         (progn
                         (vla-put-startpoint line (vlax-3d-point basept))
                         (vla-put-endpoint line (vlax-3d-point next_pt))
                         (vla-update line)
                         (setq ptt (car next_pt))
                         (if (> ptt pt)
                                         (progn
                                                         (setq text_x (+ (car next_pt) (getvar "dimgap")))
                                                         (setq l2_x (+ (car next_pt) txtlen (getvar "dimgap")))
                                         )
                                         (progn
                                                         (setq text_x (- (car next_pt) (getvar "dimgap") txtlen))
                                                         (setq l2_x text_x)
                                         )
                         )
                         (vla-put-insertionpoint
                                         text
                                         (vlax-3d-point
                                                         (list text_x (+ (cadr next_pt) (getvar "dimgap")) 0)
                                         )
                         )
                         (vla-update text)
                         (vla-put-startpoint l2 (vlax-3d-point next_pt))
                         (setq l2end (list l2_x (cadr next_pt) 0))
                         (vla-put-endpoint l2 (vlax-3d-point l2end))
                         (vla-update l2)
         )
                                                 )
                                         )
                                         ((= READTYP 3)                 ;左??
;;;                                                 (MakeUnNameBlock ss1 cen)
                                                 (setq i nil)
                                         )
                                         ((or (= 25 readtyp) (= 13 READVAL)) ;回?或右?
                                                 (setq fh1 fh)
                                                 (setq fh (getstring (strcat
                                                         "\n?入新??符? :"
                                         )
         )
                                                 )
                                                 (if (= fh "")
         (setq fh fh1)
                                                 )
                                                 (vla-put-textstring text fh)
                                                 (vla-update text)
                                                 (setq txtlen (tzz text))
                                                 (princ "\n指定??符?放置位置 :")
                                         )
                         )
         )
         (fd)
         (bdycad)
         (princ)
)
(defun fd (/ minpt maxpt ss2)
                         (vla-getboundingbox cir 'minpt 'maxpt)
                         (setq minpt (vlax-safearray->list minpt)
                 maxpt (vlax-safearray->list maxpt)
                         )
                         (setq ss2 (ssget "C" maxpt minpt))
         
                         (command "copy" ss2 "" cen)
                         (princ "\n指定放大?位置:")
         (command pause)
;;;                         (if (not (command pause))
;;;;;;                                         (MakeUnNameBlock ss1 cen)
;;;                         )
         )
(defun bdycad()
         (defun GetPoints2004-04-22 (lst1 / pt lst1 )
         (while (setq lst1 (member (assoc 10 lst1) lst1))
                         (setq pt (append pt (list (cdr (car         lst1)))))
                         (setq lst1 (cdr lst1)))
         pt
)
(setq ssb (ssget "x" (list (cons 10(getvar "lastpoint"))         (assoc 40 (entget newcircle)))))
(command ".POLYGON" 40 (getvar "lastpoint") "c" (+(cdr (assoc 40 (entget newcircle)))0.1))
(setq polsel (entlast))
(setq trimp (GetPoints2004-04-22 (entget polsel)))
(progn ;         強行修剪         搞掂
(command ".trim" ssb "" );"f" trimp)
(setq it 0)
(repeat (- (length trimp) 1)
         (setq trp1 (nth it trimp)
        trp2 (nth (1+ it) trimp))
         (command "f" trp1 trp2 "")
         (setq it (1+ it)))
(command ""))
(progn ;         強行刪除搞掂
(setq it 0)
(repeat (- (length trimp) 1)
         (setq trp1 (nth it trimp)
        trp2 (nth (1+ it) trimp))
         (if (setq erase (ssget "f" (list trp1 trp2 )))
                         (command ".erase" erase ""))
         (setq it (1+ it)))
)
         (if (=(setq scalebb (getreal "\n輸入放大的倍數:"))nil)
                         (setq scalebb 2))
(command ".scale" (ssget "cp" trimp)"" (getvar "lastpoint") scalebb)
         (princ)
         )
回复

使用道具 举报

7

主题

42

帖子

6

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
70
发表于 2004-4-25 07:34:00 | 显示全部楼层
很感谢,但不知道如何用!!
回复

使用道具 举报

57

主题

466

帖子

8

银币

中流砥柱

Rank: 25

铜币
694
发表于 2004-4-26 12:42:00 | 显示全部楼层
蛮好的,不过局部放大我很少用
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-8-16 03:25 , Processed in 1.974734 second(s), 60 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表