从cad内部提取CAD的缩略图lisp源码分享，新鲜出炉2019.6.4

xugaoming23

2. ;;----------------将xrecord的内容生成文件------------------------------------------------
   
3. (defun xrecordtofile (vlaobj filepath)
   
4.     (if        (/= (vla-get-ObjectName vlaobj) "AcDbXrecord")
   
5.         (exit)
   
6.     )
   
7.     (vla-getxrecorddata vlaobj 'xtypeOut 'xdataOut)
   
8.     (setq x (vlax-safearray->list xtypeOut))
   
9.     (setq y (vlax-safearray->list xdataOut))
   
10.     (setq z nil)
    
11.     (if        (= (vlax-safearray-type xdataOut) vlax-vbVariant)
    
12.         (progn
    
13.             (foreach i y
    
14.                 (if (> (vlax-variant-type i) 8192)
    
15.                     (progn
    
16.                         (setq j (vlax-safearray->list (vlax-variant-value i)))
    
17.                         (foreach k j (setq z (cons k z)))
    
18.                     )
    
19.                 )
    
20.             )
    
21.             (setq z (reverse z))
    
22.             ;;28456
    
23.             (setq k (list 77 66))
    
24.             (setq l (length z))
    
25.             (while (/= 0 l)
    
26.                 (setq
    
27.                     k (cons (rem l 16) k)
    
28.                     l (/ l 16)
    
29.                 )
    
30.             )
    
31.      ;6 15 2 8
    
32.             (setq k (cons 0 k))
    
33.             (setq k (cons 0 k))
    
34.             (setq k (cons 0 k))
    
35.             (setq k (cons 0 k))
    
36.             (setq k (cons 54 k))
    
37.             (setq k (cons 0 k))
    
38.             (setq k (cons 0 k))
    
39.             (setq k (cons 0 k))
    
40. 
    
41.      ;(setq k (list 66 77 8 2 15 6 0 0 0 0 54 0 0 0))
    
42.      ;(setq k (reverse k))
    
43.             (foreach i k (setq z (cons i z)))
    
44.             (setq m (vlax-make-safearray 17 (cons 0 (1- (length z))))) ;17为vbbyte
    
45.             (setq n (vlax-safearray-fill m z))
    
46.         )
    
47.     )
    
48.     (setq ObjStream (vlax-get-or-create-object "Adodb.Stream"))
    
49.     (vlax-put-property ObjStream 'Type 1) ;1为二进制模式读取 ，2为文本模式读取
    
50.     (vlax-put-property ObjStream 'Mode 3) ;1为读，2为写，3为读写
    
51.     (vlax-invoke ObjStream 'Open)
    
52.     (vlax-invoke-method ObjStream 'Write n) ;还有一个方法是writetext
    
53.     (vlax-put-property ObjStream 'Position 0) ;写文本时有效
    
54.      ;(vlax-put-property ObjStream 'Type 2);写文本时有效，编码调整
    
55.      ;(vlax-put-property ObjStream 'Charset 'unicode);写文本时有效 'unicode,utf-8,ascii,gb2312,big5,gbk
    
56.      ;(setq str (vlax-invoke-method ObjStream 'ReadText));生成字符串时有效
    
57.     (vlax-invoke-method ObjStream 'SaveToFile filepath 2) ;adSaveCreateNotExist =1 , adSaveCreateOverWrite =2
    
58.     (vlax-invoke-method ObjStream 'Close)
    
59.     (vlax-release-object ObjStream)
    
60. )
    
61. 
    
62. 
    
63. ;;--------------------------------end-------------------------------------------
    
64. (setq i (cdr (assoc -1(dictsearch (namedobjdict) "ACAD_LAYOUT"))))
    
65. (setq i (vla-Item (vla-GetExtensionDictionary (vla-Item (vlax-Ename->Vla-Object i) 0 ))0))
    
66. (xrecordtofile i "E:\\cad.bmp")
    

;;----------------将xrecord的内容生成文件------------------------------------------------<br /> (defun xrecordtofile (vlaobj filepath)<br />     (if        (/= (vla-get-ObjectName vlaobj) "AcDbXrecord")<br />         (exit)<br />     )<br />     (vla-getxrecorddata vlaobj 'xtypeOut 'xdataOut)<br />     (setq x (vlax-safearray->list xtypeOut))<br />     (setq y (vlax-safearray->list xdataOut))<br />     (setq z nil)<br />     (if        (= (vlax-safearray-type xdataOut) vlax-vbVariant)<br />         (progn<br />             (foreach i y<br />                 (if (> (vlax-variant-type i) 8192)<br />                     (progn<br />                         (setq j (vlax-safearray->list (vlax-variant-value i)))<br />                         (foreach k j (setq z (cons k z)))<br />                     )<br />                 )<br />             )<br />             (setq z (reverse z))<br />             ;;28456<br />             (setq k (list 77 66))<br />             (setq l (length z))<br />             (while (/= 0 l)<br />                 (setq<br />                     k (cons (rem l 16) k)<br />                     l (/ l 16)<br />                 )<br />             )<br />      ;6 15 2 8<br />             (setq k (cons 0 k))<br />             (setq k (cons 0 k))<br />             (setq k (cons 0 k))<br />             (setq k (cons 0 k))<br />             (setq k (cons 54 k))<br />             (setq k (cons 0 k))<br />             (setq k (cons 0 k))<br />             (setq k (cons 0 k))<br /> <br />      ;(setq k (list 66 77 8 2 15 6 0 0 0 0 54 0 0 0))<br />      ;(setq k (reverse k))<br />             (foreach i k (setq z (cons i z)))<br />             (setq m (vlax-make-safearray 17 (cons 0 (1- (length z))))) ;17为vbbyte<br />             (setq n (vlax-safearray-fill m z))<br />         )<br />     )<br />     (setq ObjStream (vlax-get-or-create-object "Adodb.Stream"))<br />     (vlax-put-property ObjStream 'Type 1) ;1为二进制模式读取 ，2为文本模式读取<br />     (vlax-put-property ObjStream 'Mode 3) ;1为读，2为写，3为读写<br />     (vlax-invoke ObjStream 'Open)<br />     (vlax-invoke-method ObjStream 'Write n) ;还有一个方法是writetext<br />     (vlax-put-property ObjStream 'Position 0) ;写文本时有效<br />      ;(vlax-put-property ObjStream 'Type 2);写文本时有效，编码调整<br />      ;(vlax-put-property ObjStream 'Charset 'unicode);写文本时有效 'unicode,utf-8,ascii,gb2312,big5,gbk<br />      ;(setq str (vlax-invoke-method ObjStream 'ReadText));生成字符串时有效<br />     (vlax-invoke-method ObjStream 'SaveToFile filepath 2) ;adSaveCreateNotExist =1 , adSaveCreateOverWrite =2<br />     (vlax-invoke-method ObjStream 'Close)<br />     (vlax-release-object ObjStream)<br /> )<br /> <br /> <br /> ;;--------------------------------end-------------------------------------------<br /> (setq i (cdr (assoc -1(dictsearch (namedobjdict) "ACAD_LAYOUT"))))<br /> (setq i (vla-Item (vla-GetExtensionDictionary (vla-Item (vlax-Ename->Vla-Object i) 0 ))0))<br /> (xrecordtofile i "E:\\cad.bmp")<br />

提供思路，不负责解释

左侧为提取的缩略图片

liwen888888

看不出和直接输出BMP JPG有什么区别

bai2000

怎么运行啊

xugaoming23

liwen888888 发表于 2019-6-5 20:39
看不出和直接输出BMP JPG有什么区别

重点是提供了一些新的想法与思路，比如xrecord下的二进制，CAD自身储存的二进制格式如何翻译，还比如图像二进制没有头文件的添加问题，没提到的安全数组类型，如17为VBbyte

xugaoming23

bai2000 发表于 2019-6-7 13:10
怎么运行啊

你都两个太阳了不会运行，先看看cad文件有没有缩略图，然后复制粘贴就可以运行了

xugaoming23

bai2000 发表于 2019-6-7 13:10
怎么运行啊

主代码是这个：
(setq i (cdr (assoc -1(dictsearch (namedobjdict) "ACAD_LAYOUT"))))
(setq i (vla-Item (vla-GetExtensionDictionary (vla-Item (vlax-Ename->Vla-Object i) 0 ))0))
(xrecordtofile i "E:\\cad.bmp")

只提供思路，程序没有严谨的去写，只是大致部位提供下条件转折，但条件也没有一 一严禁，自己用的时候需要修改完善

USER2128

楼主，能否提取图像为sld格式，这样就有办法在DCL中做到DWG预览

xugaoming23

USER2128 发表于 2019-6-12 11:26
楼主，能否提取图像为sld格式，这样就有办法在DCL中做到DWG预览

这个程序本身就不完善，我也是猜测图像的格式为bmp，结果凑了出来，如果缩略图在布局里面，主程序还要调整下扩展字典的根，至于转码以及如何应用，这个靠你自己了

xugaoming23

补充： 今天偶尔测试，居然又不行了
1.原因为byte数不稳定 ，由于系统自身运行可能导致符号位的加入，需要调整
(foreach k j (setq z (cons k z)))  调整为(foreach k j (setq z (cons (logand k 255) z)))
2.是否能提取缩略图取决于根ACAD_LAYOUT是否有Xrecord ，如果缩略图不是在这个根下，需要自己去找，cad版本的因素，可能缩略图不是Xrecord形式