[问题一]：用Solid模拟圆弧、圆、Spline、椭圆。

eachy · 发表于 2003-7-13 23:56:33

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

用Solid模拟，要求用Lisp及VL函数，不用XDAPI，同时要保持多义线的宽度。

补充：模拟精度可以指定，也可以由程序计算适宜的精度。

对积极参与求解者予以奖励。

eachy · 发表于 2003-7-15 00:02:03

贴几个预备函数

;;;(setq *acad-object* nil) ; Initialize global variable
(defun acad-object ()
(cond (*acad-object*) ; Return the cached object
(t
(setq *acad-object* (vlax-get-acad-object))
)
)
)
;;;(setq *active-document* nil) ; Initialize global variable
(defun active-document ()
(cond (*active-document*) ; Return the cached object
(t
(setq *active-document* (vla-get-activedocument (acad-object)))
)
)
)
;;;(setq *model-space* nil) ; Initialize global variable
(defun model-space ()
(cond (*model-space*) ; Return the cached object
(t
(setq *model-space* (vla-get-modelspace (active-document)))
)
)
)
(defun lisp-value (v)
(cond
((= (type v) 'variant)
(lisp-value (variant-value v))
)
((= (type v) 'safearray)
(mapcar 'lisp-value (safearray-value v))
)
(t v)
)
)
(defun list->VariantArray (lst varType)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray varType (cons 0 (1- (length lst))))
(mapcar
'(lambda (x)
(cond ((= (type x) 'list)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type x))
(cond ((= (type (car x)) 'REAL) vlax-vbDouble)
((= (type (car x)) 'INT) vlax-vbInteger)
((= (type (car x)) 'STR) vlax-vbString)
)
vlax-vbVariant
)
(cons 0 (1- (length x)))
)
x
)
)
((= (type x) 'ename)
(vlax-ename->vla-object x)
)
(t x)
)
)
lst
)
)
)
)
(defun selectionsetToArray (ss / c r)
(setq c -1)
(repeat (sslength ss)
(setq r (cons (ssname ss (setq c (1+ c))) r))
)
(setq r (reverse r))
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject (cons 0 (1- (length r))))
(mapcar 'vlax-ename->vla-object r)
)
)

;;;(setq *acad-object* nil)      ; Initialize global variable 
(defun acad-object () 
  (cond (*acad-object*)                 ; Return the cached object 
        (t 
         (setq *acad-object* (vlax-get-acad-object)) 
        ) 
  ) 
) 
 
;;;(setq *active-document* nil)  ; Initialize global variable 
(defun active-document () 
  (cond (*active-document*)             ; Return the cached object 
        (t 
         (setq *active-document* (vla-get-activedocument (acad-object))) 
        ) 
  ) 
) 
 
;;;(setq *model-space* nil)      ; Initialize global variable 
(defun model-space () 
  (cond (*model-space*)                 ; Return the cached object 
        (t 
         (setq *model-space* (vla-get-modelspace (active-document))) 
        ) 
  ) 
) 
(defun lisp-value (v) 
  (cond 
    ((= (type v) 'variant) 
     (lisp-value (variant-value v)) 
    ) 
    ((= (type v) 'safearray) 
     (mapcar 'lisp-value (safearray-value v)) 
    ) 
    (t v) 
  ) 
) 
(defun list->VariantArray (lst varType) 
  (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray varType (cons 0 (1- (length lst)))) 
      (mapcar 
        '(lambda (x) 
           (cond ((= (type x) 'list) 
                  (vlax-safearray-fill 
                    (vlax-make-safearray 
                      (if (apply '= (mapcar 'type x)) 
                        (cond ((= (type (car x)) 'REAL) vlax-vbDouble) 
                              ((= (type (car x)) 'INT) vlax-vbInteger) 
                              ((= (type (car x)) 'STR) vlax-vbString) 
                        ) 
                        vlax-vbVariant 
                      ) 
                      (cons 0 (1- (length x))) 
                    ) 
                    x 
                  ) 
                 ) 
                 ((= (type x) 'ename) 
                  (vlax-ename->vla-object x) 
                 ) 
                 (t x) 
           ) 
         ) 
        lst 
      ) 
    ) 
  ) 
) 
(defun selectionsetToArray (ss / c r) 
  (setq c -1) 
  (repeat (sslength ss) 
    (setq r (cons (ssname ss (setq c (1+ c))) r)) 
  ) 
  (setq r (reverse r)) 
  (vlax-safearray-fill 
    (vlax-make-safearray vlax-vbObject (cons 0 (1- (length r)))) 
    (mapcar 'vlax-ename->vla-object r) 
  ) 
)

eachy · 发表于 2003-7-15 00:08:53

增加Trace，Active用法

(vla-addtrace
modelspace
(list->VariantArray
ptlst
vlax-vbdouble
)
)

复制代码

ptlst 用法
(setq ptlst (apply 'append (list p1 p2 p3 p4)))

eachy · 发表于 2003-7-15 00:17:43

说明下程序的目的，一个DWG文件其直接利用的价值降到最低（几乎为0）也就实现了加密的目的，同时CAD可以打开也不会伤和气，对图谋不轨道甲方也只能哑巴吃黄莲。图形“加密”的方法经过思考简单的最佳组合：DWFOUT－>DWFIN－>再处理ARC、CIRCLE，注意其中不可用TTF字体。

msdg · 发表于 2003-7-15 13:10:36

高！期待！~

eachy · 发表于 2003-7-15 18:45:07

再贴一段。

;;发图前处理下图形 Beta 0.01
;;配合 dwfout -> dwfin 使用
;;如果可能再将图形不等比缩放一点点（不包括图框）
;;需要改进的：
;; 1 增加处理 arc circle spline 及保持宽度的Pline部分功能
;; 2 对Line分解为一点点间隙的特定长度的Trace
;;
;; Writen By eachy 2003.07.15
;; Email: [email]eachy@21cn.com[/email]
;; 图形比较大时要耐心等等呦
(defun c:killdwg (/ $same_layer activedoc modelspace
lay ln tn ss sp ep
n ptlst layers blocks
)
(setvar "cmdecho" 0)
(if (null (tblsearch "layer" "Defpoints"))
(vl-cmdf "_.layer" "m" "Defpoints" "")
)
(if (/= (getvar "clayer") "Defpoints")
(setvar "clayer" "Defpoints")
)
;;统一图层并保持颜色
(defun $same_layer (vla-object laylst / la)
(setq la (vla-get-layer vla-object))
(vla-put-layer vla-object "Defpoints")
(if (= 256 (vla-get-color vla-object))
(vla-put-color vla-object (cadr (assoc la laylst)))
)
)
(setq activedoc (vla-get-activedocument (vlax-get-acad-object))
modelspace (vla-get-modelspace activedoc)
layers (vla-get-layers activedoc)
blocks (vla-get-blocks activedoc)
)
;;获取图层列表(("layer1" color1) ("layer2" color2) ... )
(vlax-for item layers
(setq
lay (cons (list (vla-get-name item) (vla-get-color item)) lay)
)
)
(princ "\n正在处理实体....")
;;统一图层并保持颜色
(vlax-for for-item modelspace
($same_layer for-item lay)
)
;;用DWFOUT－》DWFIN的图去掉处理图块
;;处理块定义
(princ "\n正在处理图块定义...")
(vlax-for for-item blocks
(vlax-for obj for-item
($same_layer obj lay)
)
)
;;处理图块结束
;|循环分解图中所有块
(while (setq ss (ssget "x" '((0 . "region,insert,dimension,hatch"))))
(vl-cmdf "_.explode" ss)
)|;
;;变换图中Line实体
(setq n 0)
(setq ss (ssget "x" '((0 . "line"))))
(if ss
(progn
(princ "\n正在处理Line实体...")
(repeat (sslength ss)
(setq ln (vlax-ename->vla-object (ssname ss n)))
(setq sp (vlax-curve-getstartpoint ln)
ep (vlax-curve-getendpoint ln)
)
(setq ptlst (apply 'append
(list (polar sp (angle sp ep) 1e-10)
;此值可自行调整以防止用程序反处理经过本程序处理的图形
(polar sp (/ pi 3) 1e-10)
(polar ep (/ pi 3) 1e-10)
(polar ep (angle ep sp) 1e-10)
)
)
)
;;增加trace
(setq tn (vla-addtrace
modelspace
(vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble '(0 . 11))
ptlst
)
)
)
(vla-put-color tn (vla-get-color ln))
(vla-erase ln)
(setq n (1+ n))
)
)
)
(vl-cmdf "_.purge" "all" "*" "n")
(princ "\n\t===处理完成，OK!====")
(princ)
)

;;发图前处理下图形 Beta 0.01 
;;配合 dwfout -> dwfin 使用 
;;如果可能再将图形不等比缩放一点点（不包括图框） 
;;需要改进的： 
;;    1 增加处理 arc circle spline 及保持宽度的Pline部分功能 
;;    2 对Line分解为一点点间隙的特定长度的Trace 
;; 
;;                          Writen By eachy 2003.07.15 
;;                             Email: [email]eachy@21cn.com[/email] 
;; 图形比较大时要耐心等等呦 
(defun c:killdwg (/        $same_layer          activedoc            modelspace 
               lay        ln         tn          ss           sp            ep 
               n        ptlst layers blocks 
              ) 
  (setvar "cmdecho" 0) 
  (if (null (tblsearch "layer" "Defpoints")) 
    (vl-cmdf "_.layer" "m" "Defpoints" "") 
  ) 
  (if (/= (getvar "clayer") "Defpoints") 
    (setvar "clayer" "Defpoints") 
  ) 
  ;;统一图层并保持颜色 
  (defun $same_layer (vla-object laylst / la) 
    (setq la (vla-get-layer vla-object)) 
    (vla-put-layer vla-object "Defpoints") 
    (if        (= 256 (vla-get-color vla-object)) 
      (vla-put-color vla-object (cadr (assoc la laylst))) 
    ) 
  ) 
  (setq        activedoc  (vla-get-activedocument (vlax-get-acad-object)) 
        modelspace (vla-get-modelspace activedoc) 
        layers (vla-get-layers activedoc) 
        blocks (vla-get-blocks activedoc) 
  ) 
  ;;获取图层列表(("layer1" color1) ("layer2" color2) ... ) 
  (vlax-for item layers 
    (setq 
      lay (cons (list (vla-get-name item) (vla-get-color item)) lay) 
    ) 
  ) 
  (princ "\n正在处理实体....") 
  ;;统一图层并保持颜色 
  (vlax-for for-item modelspace 
    ($same_layer for-item lay) 
  ) 
  ;;用DWFOUT－》DWFIN的图去掉处理图块 
  ;;处理块定义 
  (princ "\n正在处理图块定义...") 
  (vlax-for for-item blocks 
    (vlax-for obj for-item 
      ($same_layer obj lay) 
    ) 
  ) 
  ;;处理图块结束 
  ;|循环分解图中所有块 
  (while (setq ss (ssget "x" '((0 . "region,insert,dimension,hatch")))) 
    (vl-cmdf "_.explode" ss) 
  )|; 
  ;;变换图中Line实体 
  (setq n 0) 
  (setq ss (ssget "x" '((0 . "line")))) 
  (if ss 
    (progn 
      (princ "\n正在处理Line实体...") 
      (repeat (sslength ss) 
        (setq ln (vlax-ename->vla-object (ssname ss n))) 
        (setq sp (vlax-curve-getstartpoint ln) 
              ep (vlax-curve-getendpoint ln) 
        ) 
        (setq ptlst (apply 'append 
                           (list (polar sp (angle sp ep) 1e-10) 
                                        ;此值可自行调整以防止用程序反处理经过本程序处理的图形 
                                 (polar sp (/ pi 3) 1e-10) 
                                 (polar ep (/ pi 3) 1e-10) 
                                 (polar ep (angle ep sp) 1e-10) 
                           ) 
                    ) 
        ) 
        ;;增加trace 
        (setq tn (vla-addtrace 
                   modelspace 
                   (vlax-safearray-fill 
                     (vlax-make-safearray vlax-vbDouble '(0 . 11)) 
                     ptlst 
                   ) 
                 ) 
        ) 
        (vla-put-color tn (vla-get-color ln)) 
        (vla-erase ln) 
        (setq n (1+ n)) 
      ) 
    ) 
  ) 
  (vl-cmdf "_.purge" "all" "*" "n") 
  (princ "\n\t===处理完成，OK!====") 
  (princ) 
)

eachy · 发表于 2003-7-16 08:21:22

;|Curve 类 AcDbLine、AcDbPolyline(lwpolyline),AcDbArc,AcDbCircle,AcDbEllipse,
AcDbSpline AcDb2dPolyline
|;
(defun $ea_iscurve (objectname)
(member objectname
'("AcDbArc" "AcDbPolyLine" "AcDbLine"
"AcDbEllipse" "AcDbSpline" "AcDbCircle"
"AcDb2dPolyline"
)
)
)
;;获取Curve类曲线的面积，周长
(defun ea:getarea (e / obj)
(setq obj (vlax-ename->vla-object e))
(if ($ea_iscurve (vla-get-objectname obj))
(list (vlax-curve-getarea obj)
(vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj))
)
nil
)
)

eachy · 发表于 2003-7-18 14:14:08

没有人响应呀？继续贴一部分。
killdwg －简单处理图形程序，用Trace模拟Line、Arc、Circle、Spline、没有宽度的Pline。
模拟精度控制断线的长度，可以采用默认值。处理后的实体位于Defpoints图层但保持原图层颜色。

尚不能处理的几个问题：文字、线型、不等宽多义线。

说明：
处理之前你还可以执行下面几句，当然对含属性的块可以用CAD扩展工具中的xexplode.

(defun c:expall (/ ss)
(setvar "qaflags" 1)
(while (setq ss (ssget "x"
'((0 . "hatch,insert,dimension,region")
(100 . "acdb3dpolyline")
(100 . "acdb2dpolyline")
)
)
)
(vl-cmdf ".explode" ss "")
(setq ss nil)
)
(vl-cmdf ".purge" "all" "*" "n")
(princ)
)

aeo · 发表于 2003-7-19 08:49:56

你肯定要保证可以打印吧.

那我打出来扫描,再矢量化.

其实dwfout----dwfin已经可以了.ttf再分解一下.鬼才乐意再改来改去的了.

eachy · 发表于 2003-7-19 09:19:35

最初由 aeo 发布
[B]你肯定要保证可以打印吧.

那我打出来扫描,再矢量化.

其实dwfout----dwfin已经可以了.ttf再分解一下.鬼才乐意再改来改去的了. [/B]

目的只是降低直接利用DWG的可能，让你扫描矢量化就已经达到程序的目的了。

账号		自动登录	找回密码
密码			立即注册

[问题一]：用Solid模拟圆弧、圆、Spline、椭圆。

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子