怎么批量选取tif图像插入cad中

xcz123m · 发表于 2017-10-12 21:33:39

本帖最后由 xcz123m 于 2017-11-19 00:44 编辑

这个只能单张插入像图的，getfiled 只能单个选取………现在想批量选取一个文件夹下的多个tif文件插入，用什么函数呢？各位大牛帮帮忙！！

补充：插入一个文件夹的下的全部tif文件已经实现，现在想我有时不用全部插入就只需插入几张（可以自己选择），应该怎么写呢？会用到dcl吧？

;;; 读取并计算tfw文件参数

  (setq tfwname (strcat (substr imageName 1 (- (strlen imageName) 3)) "tfw"))

  (setq fp (open tfwname "r"))
  (setq reco (read-line fp) ii 1)
  (setq chat nil)
  (while reco
   (setq chat (append (list reco) chat))
   (setq reco (read-line fp) ii (1+ ii))
)  ;end while
  (close fp)

  (setq pt (list (atof (nth 1 chat)) (atof (nth 0 chat)) 0))
  (setq bl (atof (nth 5 chat)))

  (setq insertionPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))

  (vlax-safearray-fill insertionPnt pt )

;;; 在模型空间中建立一个光栅图像

补充一下每张tif影像都有一张同名的tfw坐标文件。
谢谢  Atsai 已经可以实现了…………

Atsai · 发表于 2017-10-16 22:32:13

下面的GEOTiff.lsp的代码可单一图片『插入带座标的影像档』、『汇出既有影像的座标讯息，ex：tfw』，不支援旋转。

      GetFilesV1-6.lsp(by Lee Mac)是支援档案多选的代码

上面二个组合一下就可以实现楼主的批量插入带座标的Tiff档了。

这个是Lee Mac程式的图像演示：

座标档的格式及转换方式可以自行搜寻百度：TFW格式：
https://baike.baidu.com/item/TFW%E6%A0%BC%E5%BC%8F

座标转换的公式
x'=Ax+By+C
y'=Dx+Ey+F

座標档格式
1.02040816326531          A：每個像素(pixel)在 x軸上的長度
0                                     D：x軸的旋轉量
0                                     B：y軸的旋轉量
-1.02040816326531       E：每個像素(pixel)在 y軸上的長度
428000                            C：影像左上角的x座標值
2556800                         F：影像左上角的y座標值

yangqingchao · 发表于 2018-5-7 16:28:37

本帖最后由 yangqingchao 于 2018-5-7 16:34 编辑

本人也经常用到这个功能，一直都没找到合适的，只能单张插入，今天看到@Atsai提供的文件，使用起感觉非常方便，于是就将两个文件稍加整合，基本能实现楼主所说的功能，由于我不懂编程，所以难免有很多错误，但我自己测试基本功能可以使用，大神们不要喷我。

(vl-load-com)
(if (null degrad)
(defun degrad (ang)
(* pi (/ ang 180.0))
)
)
(if (null raddeg)
(defun raddeg (ang)
(* 180.0 (/ ang pi))
)
)
(defun c:iimg()
(initget "1 2")
(princ "\n选择插入影像方式:")
(setq key (getkword "\n1单张\\2批量\\<1>:"))
(cond ((not key) (dz)) ;
((= key "1") (dz)) ;
((= key "2") (pl)) ;
);cond
)
(defun dz()
(findfile (setq im (getfiled "Select Image File"
(getvar "dwgprefix")
"tif;jpg;png;ecw"
16
)
)
)
(tfw im)
)
(defun pl()
(setq dir (LM:getfiles "选择文件" "" "tif;jpg;png;ecw"))
(repeat (setq n (length dir))
(setq n (1- n))
(setq e (nth n dir))
(tfw e)
)
(princ (strcat "\n成功插入 " (itoa (length dir)) "个影像！"))
(princ)
)
(defun tfw ( im / img file res pt xres yres xrot yrot left top minpt maxpt)
;define the function name and variables
(if (= (type im) 'str)
(progn
(setq img
(vla-addraster
(vla-get-block
(vla-get-activelayout
(vla-get-activedocument (vlax-get-acad-object))
)
)
im
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 2))
'(0.0 0.0 0.0)
)
)
1.0
0.0
)
)
(if (snvalid (vl-filename-base im))
(vla-put-name img (vl-filename-base im))
)
(setq im (vlax-vla-object->ename img))
)
(setq imG (vlax-ename->vla-object (ssname im 0)))
)
(if (findfile (vl-string-subst
".ers"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(setq file (vl-string-subst
".ers"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(if (findfile (vl-string-subst
".tfw"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(setq file (vl-string-subst
".tfw"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(if (findfile (vl-string-subst
".jgw"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(setq file (vl-string-subst
".jgw"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(if (findfile (vl-string-subst
".pgw"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
(setq file (vl-string-subst
".pgw"
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
)
)
)
)
)
(if (or file
(setq file (getfiled "Select World File"
(vl-string-subst
""
(vl-filename-extension (vla-get-imagefile img))
(vla-get-imagefile img)
)
"tfw;jgw;pgw;ers"
0
)
)
)
(if (= (vl-filename-extension file) ".ers")
(progn
(setq file (open file "r"))
(repeat 19 (read-line file))
(setq left (atof (last (split (read-line file) " ")))
top (atof (last (split (read-line file) " ")))
)
(close file)
(vla-put-origin
img
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray 5 (cons 0 2))
(list left (- top (vla-get-height img)) 0.0)
)
)
)
(vla-put-imagewidth img (vla-get-width img))
(vla-put-imageheight img (vla-get-height img))
(vla-getboundingbox img 'minpt 'maxpt)
(vla-zoomwindow (vlax-get-acad-object) minpt maxpt)
)
(progn
(setq file (open file "r")
xres (atof (read-line file))
xrot (atof (read-line file))
yrot (atof (read-line file))
yres (atof (read-line file))
ins (list (atof (read-line file)) (atof (read-line file)) 0.0)
ins (polar ins
(* (/ (+ xrot 90.0) 180.0) pi)
(* (vla-get-height img) yres)
)
)
(close file)
(vla-put-rotation img (degrad xrot))
(vla-put-origin
img
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray 5 (cons 0 2)) ins)
)
)
(vla-put-imageheight
img
(* (vla-get-height img) (abs yres))
)
(vla-put-imagewidth img (* (vla-get-width img) (abs xres)))
(vla-getboundingbox img 'minpt 'maxpt)
(vla-zoomwindow (vlax-get-acad-object) minpt maxpt)
)
)
)
;)
; )
(princ) ;exit quietly
)

(vl-load-com) 
 
(if (null degrad) 
  (defun degrad  (ang) 
    (* pi (/ ang 180.0)) 
  ) 
) 
 
(if (null raddeg) 
  (defun raddeg  (ang) 
    (* 180.0 (/ ang pi)) 
  ) 
) 
(defun c:iimg() 
    (initget "1 2") 
    (princ "\n选择插入影像方式:") 
    (setq key (getkword "\n1单张\\2批量\\<1>:")) 
       (cond ((not key) (dz))    ; 
       ((= key "1") (dz))  ; 
       ((= key "2") (pl))  ; 
       );cond 
) 
  (defun dz() 
   (findfile (setq im (getfiled "Select Image File" 
               (getvar "dwgprefix") 
               "tif;jpg;png;ecw" 
               16 
           ) 
        ) 
    ) 
  (tfw im)    
  ) 
  (defun pl() 
    (setq dir (LM:getfiles "选择文件" "" "tif;jpg;png;ecw")) 
    (repeat (setq n (length dir)) 
      (setq n (1- n)) 
      (setq e (nth n dir)) 
      (tfw e) 
    ) 
    (princ (strcat "\n成功插入 " (itoa (length dir)) "个影像！")) 
    (princ) 
  ) 
 
 
(defun tfw ( im / img file res pt  xres yres xrot yrot left top minpt maxpt) 
          ;define the function name and variables 
      (if (= (type im) 'str) 
  (progn 
    (setq  img 
     (vla-addraster 
       (vla-get-block 
         (vla-get-activelayout 
           (vla-get-activedocument (vlax-get-acad-object)) 
         ) 
       ) 
       im 
       (vlax-make-variant 
         (vlax-safearray-fill 
           (vlax-make-safearray vlax-vbdouble (cons 0 2)) 
           '(0.0 0.0 0.0) 
         ) 
       ) 
       1.0 
       0.0 
     ) 
    ) 
    (if (snvalid (vl-filename-base im)) 
      (vla-put-name img (vl-filename-base im)) 
    ) 
    (setq im (vlax-vla-object->ename img)) 
  ) 
  (setq imG (vlax-ename->vla-object (ssname im 0))) 
      ) 
      (if (findfile (vl-string-subst 
          ".ers" 
          (vl-filename-extension (vla-get-imagefile img)) 
          (vla-get-imagefile img) 
        ) 
    ) 
  (setq file (vl-string-subst 
         ".ers" 
         (vl-filename-extension (vla-get-imagefile img)) 
         (vla-get-imagefile img) 
       ) 
  ) 
  (if (findfile (vl-string-subst 
      ".tfw" 
      (vl-filename-extension (vla-get-imagefile img)) 
      (vla-get-imagefile img) 
          ) 
      ) 
    (setq  file (vl-string-subst 
           ".tfw" 
           (vl-filename-extension (vla-get-imagefile img)) 
           (vla-get-imagefile img) 
         ) 
    ) 
    (if (findfile  (vl-string-subst 
        ".jgw" 
        (vl-filename-extension (vla-get-imagefile img)) 
        (vla-get-imagefile img) 
      ) 
        ) 
      (setq file (vl-string-subst 
       ".jgw" 
       (vl-filename-extension (vla-get-imagefile img)) 
       (vla-get-imagefile img) 
           ) 
      ) 
      (if  (findfile (vl-string-subst 
          ".pgw" 
          (vl-filename-extension (vla-get-imagefile img)) 
          (vla-get-imagefile img) 
        ) 
    ) 
        (setq file (vl-string-subst 
         ".pgw" 
         (vl-filename-extension (vla-get-imagefile img)) 
         (vla-get-imagefile img) 
       ) 
        ) 
      ) 
    ) 
  ) 
      ) 
      (if (or file 
        (setq file (getfiled "Select World File" 
           (vl-string-subst 
             "" 
             (vl-filename-extension (vla-get-imagefile img)) 
             (vla-get-imagefile img) 
           ) 
           "tfw;jgw;pgw;ers" 
           0 
       ) 
        ) 
    ) 
  (if (= (vl-filename-extension file) ".ers") 
    (progn 
      (setq file (open file "r")) 
      (repeat 19 (read-line file)) 
      (setq left (atof (last (split (read-line file) " "))) 
      top  (atof (last (split (read-line file) " "))) 
      ) 
      (close file) 
      (vla-put-origin 
        img 
        (vlax-make-variant 
    (vlax-safearray-fill 
      (vlax-make-safearray 5 (cons 0 2)) 
      (list left (- top (vla-get-height img)) 0.0) 
    ) 
        ) 
      ) 
      (vla-put-imagewidth img (vla-get-width img)) 
      (vla-put-imageheight img (vla-get-height img)) 
      (vla-getboundingbox img 'minpt 'maxpt) 
      (vla-zoomwindow (vlax-get-acad-object) minpt maxpt) 
    ) 
    (progn 
      (setq file (open file "r") 
      xres (atof (read-line file)) 
      xrot (atof (read-line file)) 
      yrot (atof (read-line file)) 
      yres (atof (read-line file)) 
      ins  (list (atof (read-line file)) (atof (read-line file)) 0.0) 
      ins  (polar ins 
            (* (/ (+ xrot 90.0) 180.0) pi) 
            (* (vla-get-height img) yres) 
           ) 
      ) 
      (close file) 
      (vla-put-rotation img (degrad xrot)) 
      (vla-put-origin 
        img 
        (vlax-make-variant 
    (vlax-safearray-fill (vlax-make-safearray 5 (cons 0 2)) ins) 
        ) 
      ) 
      (vla-put-imageheight 
        img 
        (* (vla-get-height img) (abs yres)) 
      ) 
      (vla-put-imagewidth img (* (vla-get-width img) (abs xres))) 
      (vla-getboundingbox img 'minpt 'maxpt) 
      (vla-zoomwindow (vlax-get-acad-object) minpt maxpt) 
    ) 
  ) 
      ) 
    ;) 
;  ) 
  (princ)        ;exit quietly 
)

儁傑 · 发表于 2018-9-26 09:40:14

本帖最后由儁傑于 2018-9-26 10:05 编辑

补充21楼，结合自己碰到的小问题说明一下：
21楼的代码的前置是运行9楼的 GetFilesV1-6.lsp(by Lee Mac)
21楼的代码不含最开始的 [code="lisp]
 以及最后的 [/code]
以上之后本人运行成功。以下是拼合9+21楼的版本
PS：同21楼，不太懂，拿来主义，只是搬运工。
(defun LM:getfiles ( msg def ext / *error* dch dcl des dir dirdata lst rtn )

(defun *error* ( msg )
 (if (= 'file (type des))
 (close des)
 )
 (if (and (= 'int (type dch)) (< 0 dch))
 (unload_dialog dch)
 )
 (if (and (= 'str (type dcl)) (findfile dcl))
 (vl-file-delete dcl)
 )
 (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
 (princ (strcat "\nError: " msg))
 )
 (princ)
)

(if
 (and
 (setq dcl (vl-filename-mktemp nil nil ".dcl"))
 (setq des (open dcl "w"))
 (progn
 (foreach x
 '(
 "lst : list_box"
 "{"
 " width = 40.0;"
 " height = 20.0;"
 " fixed_width = true;"
 " fixed_height = true;"
 " alignment = centered;"
 " multiple_select = true;"
 "}"
 "but : button"
 "{"
 " width = 20.0;"
 " height = 1.8;"
 " fixed_width = true;"
 " fixed_height = true;"
 " alignment = centered;"
 "}"
 "getfiles : dialog"
 "{"
 " key = \"title\"; spacer;"
 " : row"
 " {"
 " alignment = centered;"
 " : edit_box { key = \"dir\"; label = \"Folder:\"; }"
 " : button"
 " {"
 " key = \"brw\";"
 " label = \"Browse\";"
 " fixed_width = true;"
 " }"
 " }"
 " spacer;"
 " : row"
 " {"
 " : column"
 " {"
 " : lst { key = \"box1\"; }"
 " : but { key = \"add\" ; label = \"Add Files\"; }"
 " }"
 " : column {"
 " : lst { key = \"box2\"; }"
 " : but { key = \"del\" ; label = \"Remove Files\"; }"
 " }"
 " }"
 " spacer; ok_cancel;"
 "}"
 )
 (write-line x des)
 )
 (setq des (close des))
 (< 0 (setq dch (load_dialog dcl)))
 )
 (new_dialog "getfiles" dch)
 )
 (progn
 (setq ext (if (= 'str (type ext)) (LM:getfiles:str->lst (strcase ext) ";") '("*")))
 (set_tile "title" (if (member msg '(nil "")) "Select Files" msg))
 (set_tile "dir"
 (setq dir
 (LM:getfiles:fixdir
 (if (or (member def '(nil "")) (not (vl-file-directory-p (LM:getfiles:fixdir def))))
 (getvar 'dwgprefix)
 def
 )
 )
 )
 )
 (setq lst (LM:getfiles:updatefilelist dir ext nil))
 (mode_tile "add" 1)
 (mode_tile "del" 1)

 (action_tile "brw"
 (vl-prin1-to-string
 '(if (setq tmp (LM:getfiles:browseforfolder "" nil 512))
 (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir tmp)) ext rtn)
 rtn (LM:getfiles:updateselected dir rtn)
 )
 )
 )
 )

 (action_tile "dir"
 (vl-prin1-to-string
 '(if (= 1 $reason)
 (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir (LM:getfiles:fixdir $value))) ext rtn)
 rtn (LM:getfiles:updateselected dir rtn)
 )
 )
 )
 )

 (action_tile "box1"
 (vl-prin1-to-string
 '(
 (lambda ( / itm tmp )
 (if (setq itm (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" $value ")"))))
 (if (= 4 $reason)
 (cond
 ( (equal '("..") itm)
 (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir (LM:getfiles:updir dir))) ext rtn)
 rtn (LM:getfiles:updateselected dir rtn)
 )
 )
 ( (vl-file-directory-p (setq tmp (LM:getfiles:checkredirect (strcat dir "\\" (car itm)))))
 (setq lst (LM:getfiles:updatefilelist (set_tile "dir" (setq dir tmp)) ext rtn)
 rtn (LM:getfiles:updateselected dir rtn)
 )
 )
 ( (setq rtn (LM:getfiles:sort (append rtn (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)))
 rtn (LM:getfiles:updateselected dir rtn)
 lst (LM:getfiles:updatefilelist dir ext rtn)
 )
 )
 )
 (if (vl-every '(lambda ( x ) (vl-file-directory-p (strcat dir "\\" x))) itm)
 (mode_tile "add" 1)
 (mode_tile "add" 0)
 )
 )
 )
 )
 )
 )
 )

 (action_tile "box2"
 (vl-prin1-to-string
 '(
 (lambda ( / itm )
 (if (setq itm (mapcar '(lambda ( n ) (nth n rtn)) (read (strcat "(" $value ")"))))
 (if (= 4 $reason)
 (setq rtn (LM:getfiles:updateselected dir (vl-remove (car itm) rtn))
 lst (LM:getfiles:updatefilelist dir ext rtn)
 )
 (mode_tile "del" 0)
 )
 )
 )
 )
 )
 )

 (action_tile "add"
 (vl-prin1-to-string
 '(
 (lambda ( / itm )
 (if
 (setq itm
 (vl-remove-if 'vl-file-directory-p
 (mapcar '(lambda ( n ) (nth n lst)) (read (strcat "(" (get_tile "box1") ")")))
 )
 )
 (setq rtn (LM:getfiles:sort (append rtn (mapcar '(lambda ( x ) (strcat dir "\\" x)) itm)))
 rtn (LM:getfiles:updateselected dir rtn)
 lst (LM:getfiles:updatefilelist dir ext rtn)
 )
 )
 (mode_tile "add" 1)
 (mode_tile "del" 1)
 )
 )
 )
 )

 (action_tile "del"
 (vl-prin1-to-string
 '(
 (lambda ( / itm )
 (if (setq itm (read (strcat "(" (get_tile "box2") ")")))
 (setq rtn (LM:getfiles:updateselected dir (LM:getfiles:removeitems itm rtn))
 lst (LM:getfiles:updatefilelist dir ext rtn)
 )
 )
 (mode_tile "add" 1)
 (mode_tile "del" 1)
 )
 )
 )
 )

 (if (zerop (start_dialog))
 (setq rtn nil)
 )
 )
)
(*error* nil)
rtn
)

(defun LM:getfiles:listbox ( key lst )
(start_list key)
(foreach x lst (add_list x))
(end_list)
lst
)

(defun LM:getfiles:listfiles ( dir ext lst )
(vl-remove-if '(lambda ( x ) (member (strcat dir "\\" x) lst))
 (cond
 ( (cdr (assoc dir dirdata)))
 ( (cdar
 (setq dirdata
 (cons
 (cons dir
 (append
 (LM:getfiles:sortlist (vl-remove "." (vl-directory-files dir nil -1)))
 (LM:getfiles:sort
 (if (member ext '(("") ("*")))
 (vl-directory-files dir nil 1)
 (vl-remove-if-not
 (function
 (lambda ( x / e )
 (and
 (setq e (vl-filename-extension x))
 (setq e (strcase (substr e 2)))
 (vl-some '(lambda ( w ) (wcmatch e w)) ext)
 )
 )
 )
 (vl-directory-files dir nil 1)
 )
 )
 )
 )
 )
 dirdata
 )
 )
 )
 )
 )
)
)

(defun LM:getfiles:checkredirect ( dir / itm pos )
(cond
 ( (vl-directory-files dir) dir)
 ( (and
 (= (strcase (getenv "UserProfile"))
 (strcase (substr dir 1 (setq pos (vl-string-position 92 dir nil t))))
 )
 (setq itm
 (cdr
 (assoc (substr (strcase dir t) (+ pos 2))
 '(
 ("my documents" . "Documents")
 ("my pictures" . "Pictures")
 ("my videos" . "Videos")
 ("my music" . "Music")
 )
 )
 )
 )
 (vl-file-directory-p (setq itm (strcat (substr dir 1 pos) "\\" itm)))
 )
 itm
 )
 ( dir )
)
)

(defun LM:getfiles:sort ( lst )
(apply 'append
 (mapcar 'LM:getfiles:sortlist
 (vl-sort
 (LM:getfiles:groupbyfunction lst
 (lambda ( a b / x y )
 (and
 (setq x (vl-filename-extension a))
 (setq y (vl-filename-extension b))
 (= (strcase x) (strcase y))
 )
 )
 )
 (function
 (lambda ( a b / x y )
 (and
 (setq x (vl-filename-extension (car a)))
 (setq y (vl-filename-extension (car b)))
 (< (strcase x) (strcase y))
 )
 )
 )
 )
 )
)
)

(defun LM:getfiles:sortlist ( lst )
(mapcar (function (lambda ( n ) (nth n lst)))
 (vl-sort-i (mapcar 'LM:getfiles:splitstring lst)
 (function
 (lambda ( a b / x y )
 (while
 (and
 (setq x (car a))
 (setq y (car b))
 (= x y)
 )
 (setq a (cdr a)
 b (cdr b)
 )
 )
 (cond
 ( (null x) b)
 ( (null y) nil)
 ( (and (numberp x) (numberp y)) (< x y))
 ( (numberp x))
 ( (numberp y) nil)
 ( (< x y))
 )
 )
 )
 )
)
)

(defun LM:getfiles:groupbyfunction ( lst fun / tmp1 tmp2 x1 )
(if (setq x1 (car lst))
 (progn
 (foreach x2 (cdr lst)
 (if (fun x1 x2)
 (setq tmp1 (cons x2 tmp1))
 (setq tmp2 (cons x2 tmp2))
 )
 )
 (cons (cons x1 (reverse tmp1)) (LM:getfiles:groupbyfunction (reverse tmp2) fun))
 )
)
)

(defun LM:getfiles:splitstring ( str )
(
 (lambda ( l )
 (read
 (strcat "("
 (vl-list->string
 (apply 'append
 (mapcar
 (function
 (lambda ( a b c )
 (cond
 ( (member b '(45 46 92))
 (list 32)
 )
 ( (< 47 b 58)
 (list b)
 )
 ( (list 32 34 b 34 32))
 )
 )
 )
 (cons nil l) l (append (cdr l) '(( )))
 )
 )
 )
 ")"
 )
 )
 )
 (vl-string->list (strcase str))
)
)

(defun LM:getfiles:browseforfolder ( msg dir flg / err fld pth shl slf )
(setq err
 (vl-catch-all-apply
 (function
 (lambda ( / app hwd )
 (if (setq app (vlax-get-acad-object)
 shl (vla-getinterfaceobject app "shell.application")
 hwd (vl-catch-all-apply 'vla-get-hwnd (list app))
 fld (vlax-invoke-method shl 'browseforfolder (if (vl-catch-all-error-p hwd) 0 hwd) msg flg dir)
 )
 (setq slf (vlax-get-property fld 'self)
 pth (LM:getfiles:fixdir (vlax-get-property slf 'path))
 )
 )
 )
 )
 )
)
(if slf (vlax-release-object slf))
(if fld (vlax-release-object fld))
(if shl (vlax-release-object shl))
(if (vl-catch-all-error-p err)
 (prompt (vl-catch-all-error-message err))
 pth
)
)

(defun LM:getfiles:full->relative ( dir path / p q )
(setq dir (vl-string-right-trim "\\" dir))
(cond
 ( (and
 (setq p (vl-string-position 58 dir))
 (setq q (vl-string-position 58 path))
 (/= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
 )
 path
 )
 ( (and
 (setq p (vl-string-position 92 dir))
 (setq q (vl-string-position 92 path))
 (= (strcase (substr dir 1 p)) (strcase (substr path 1 q)))
 )
 (LM:getfiles:full->relative (substr dir (+ 2 p)) (substr path (+ 2 q)))
 )
 ( (and
 (setq q (vl-string-position 92 path))
 (= (strcase dir) (strcase (substr path 1 q)))
 )
 (strcat ".\\" (substr path (+ 2 q)))
 )
 ( (= "" dir)
 path
 )
 ( (setq p (vl-string-position 92 dir))
 (LM:getfiles:full->relative (substr dir (+ 2 p)) (strcat "..\\" path))
 )
 ( (LM:getfiles:full->relative "" (strcat "..\\" path)))
)
)

(defun LM:getfiles:str->lst ( str del / pos )
(if (setq pos (vl-string-search del str))
 (cons (substr str 1 pos) (LM:getfiles:str->lst (substr str (+ pos 1 (strlen del))) del))
 (list str)
)
)

(defun LM:getfiles:updatefilelist ( dir ext lst )
(LM:getfiles:listbox "box1" (LM:getfiles:listfiles dir ext lst))
)

(defun LM:getfiles:updateselected ( dir lst )
(LM:getfiles:listbox "box2" (mapcar '(lambda ( x ) (LM:getfiles:full->relative dir x)) lst))
lst
)

(defun LM:getfiles:updir ( dir )
(substr dir 1 (vl-string-position 92 dir nil t))
)

(defun LM:getfiles:fixdir ( dir )
(vl-string-right-trim "\\" (vl-string-translate "/" "\\" dir))
)

(defun LM:getfiles:removeitems ( itm lst / idx )
(setq idx -1)
(vl-remove-if '(lambda ( x ) (member (setq idx (1+ idx)) itm)) lst)
)

(vl-load-com) (princ)

(vl-load-com)

(if (null degrad)
 (defun degrad (ang)
(* pi (/ ang 180.0))
 )
)

(if (null raddeg)
 (defun raddeg (ang)
(* 180.0 (/ ang pi))
 )
)
(defun c:ii()
(initget "1 2")
(princ "\n选择插入影像方式:")
(setq key (getkword "\n1单张\\2批量\\<1>:"))
 (cond ((not key) (dz)) ;
 ((= key "1") (dz)) ;
 ((= key "2") (pl)) ;
 );cond
)
 (defun dz()
(findfile (setq im (getfiled "Select Image File"
 (getvar "dwgprefix")
 "tif;jpg;png;ecw"
 16
 )
 )
)
 (tfw im)
 )
 (defun pl()
(setq dir (LM:getfiles "选择文件" "" "tif;jpg;png;ecw"))
(repeat (setq n (length dir))
 (setq n (1- n))
 (setq e (nth n dir))
 (tfw e)
)
(princ (strcat "\n成功插入 " (itoa (length dir)) "个影像！"))
(princ)
 )

(defun tfw ( im / img file res pt xres yres xrot yrot left top minpt maxpt)
 ;define the function name and variables
 (if (= (type im) 'str)
 (progn
(setq img
 (vla-addraster
 (vla-get-block
 (vla-get-activelayout
 (vla-get-activedocument (vlax-get-acad-object))
 )
 )
 im
 (vlax-make-variant
 (vlax-safearray-fill
 (vlax-make-safearray vlax-vbdouble (cons 0 2))
 '(0.0 0.0 0.0)
 )
 )
 1.0
 0.0
 )
)
(if (snvalid (vl-filename-base im))
 (vla-put-name img (vl-filename-base im))
)
(setq im (vlax-vla-object->ename img))
 )
 (setq imG (vlax-ename->vla-object (ssname im 0)))
 )
 (if (findfile (vl-string-subst
 ".ers"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
)
 (setq file (vl-string-subst
 ".ers"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
 )
 (if (findfile (vl-string-subst
 ".tfw"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
 )
(setq file (vl-string-subst
 ".tfw"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
)
(if (findfile (vl-string-subst
 ".jgw"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
 )
 (setq file (vl-string-subst
 ".jgw"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
 )
 (if (findfile (vl-string-subst
 ".pgw"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
)
 (setq file (vl-string-subst
 ".pgw"
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
 )
 )
)
 )
 )
 (if (or file
 (setq file (getfiled "Select World File"
 (vl-string-subst
 ""
 (vl-filename-extension (vla-get-imagefile img))
 (vla-get-imagefile img)
 )
 "tfw;jgw;pgw;ers"
 0
 )
 )
)
 (if (= (vl-filename-extension file) ".ers")
(progn
 (setq file (open file "r"))
 (repeat 19 (read-line file))
 (setq left (atof (last (split (read-line file) " ")))
 top (atof (last (split (read-line file) " ")))
 )
 (close file)
 (vla-put-origin
 img
 (vlax-make-variant
(vlax-safearray-fill
 (vlax-make-safearray 5 (cons 0 2))
 (list left (- top (vla-get-height img)) 0.0)
)
 )
 )
 (vla-put-imagewidth img (vla-get-width img))
 (vla-put-imageheight img (vla-get-height img))
 (vla-getboundingbox img 'minpt 'maxpt)
 (vla-zoomwindow (vlax-get-acad-object) minpt maxpt)
)
(progn
 (setq file (open file "r")
 xres (atof (read-line file))
 xrot (atof (read-line file))
 yrot (atof (read-line file))
 yres (atof (read-line file))
 ins (list (atof (read-line file)) (atof (read-line file)) 0.0)
 ins (polar ins
 (* (/ (+ xrot 90.0) 180.0) pi)
 (* (vla-get-height img) yres)
 )
 )
 (close file)
 (vla-put-rotation img (degrad xrot))
 (vla-put-origin
 img
 (vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray 5 (cons 0 2)) ins)
 )
 )
 (vla-put-imageheight
 img
 (* (vla-get-height img) (abs yres))
 )
 (vla-put-imagewidth img (* (vla-get-width img) (abs xres)))
 (vla-getboundingbox img 'minpt 'maxpt)
 (vla-zoomwindow (vlax-get-acad-object) minpt maxpt)
)
 )
 )
;)
; )
 (princ) ;exit quietly
)

yoyoho · 发表于 2017-10-13 00:17:47

感谢分享程序!!!!

xyp1964 · 发表于 2017-10-13 08:43:44

;; tt(批量插入图像)
(defun c:tt ()
  (setq pt  '(0 0)
sc  10
lst (xyp-MSelect)
  )
  (alert (strcat "\n共选择图像 " (itoa (length lst)) " 个"))
  (foreach a lst
(princ ".")
(command "-image" "" a "non" pt sc 0)
(setq pt (polar pt 0 (+ sc 2)))
  )
  (command "zoom" "e" "zoom" "0.8x")
  (princ)
)

天下逍遥 · 发表于 2017-10-13 11:04:50

老大厉害啊，顶顶顶

fsafaffa · 发表于 2017-10-13 11:08:26

院长速度啊

逍遥天下 · 发表于 2017-10-13 11:12:40

顶顶顶顶顶顶顶

xcz123m · 发表于 2017-10-13 19:43:16

xyp1964 发表于 2017-10-13 08:43
;; tt(批量插入图像)
(defun c:tt ()
(setq pt '(0 0)

厉害！！

xyp-MSelect 不发的吧！？

pengfei2010 · 发表于 2017-10-16 08:50:16

回帖是一种美德！感谢楼主的无私分享谢谢

xcz123m · 发表于 2017-10-17 00:13:52

Atsai 发表于 2017-10-16 22:32
下面的GEOTiff.lsp的代码可单一图片『插入带座标的影像档』、『汇出既有影像的座标讯息，ex：tfw』，不支援 ...

非常感谢谢谢！！！！

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

[提问] 怎么批量选取tif图像插入cad中

本帖子中包含更多资源

本帖被以下淘专辑推荐:

本帖子中包含更多资源

本帖子中包含更多资源