批量加载TIF格式影像文件

tjmxyz · 发表于 2018-3-22 09:28:26

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

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

×

autolisp根据tfw文件，自动判断影像坐标，加载影像。(文件选择程序来自网络）

(defun AddTif ( 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 = \"目录\"; }"
" : button"
" {"
" key = \"brw\";"
" label = \"浏览\";"
" fixed_width = true;"
" }"
" }"
" spacer;"
" : row"
" {"
" : column"
" {"
" : lst { key = \"box1\"; }"
" : but { key = \"add\" ; label = \"添加文件\"; }"
" }"
" : column {"
" : lst { key = \"box2\"; }"
" : but { key = \"del\" ; label = \"移除文件\"; }"
" }"
" }"
" 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 "")) "文件选择 BY END." 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
(yxpj 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)
)
(princ)
(defun yxpj ( tiflist / tifffile tifffilename lujing f1 fb1 xs txkd sdj1 sfb1 basept y1 y x1 x line1 i j)
(vl-load-com)
(setq i 0);初始化循环变量
(setq j 0)
(repeat (length tiflist)
(setq tifffile (nth i tiflist))
(setq tifffilename(strcat (vl-filename-base tifffile) ".tfw"))
(setq lujing(strcat (vl-filename-directory tifffile) "\\" tifffilename));生成影像图和TFW文件路径
(setq f1 (open lujing "r"))
(setq line1 (read-line f1));读取tfw文件
(setq fb1 (substr line1 1 12))
(while(= j 0)
(setq txkd 1)
(prompt "\n 输入图像宽度的像素尺寸：")
(setq xs (getreal));用户输入数据
(setq sdj1 (* (distof fb1 2) xs));计算图像宽度的实地距离
(setq sfb1 (/ sdj1 txkd));计算缩放比例
(prompt "\n 缩放比例为：")
(princ sfb1)
(setq j 1)
);/while
(setq y1 (substr line1 50 17));读取x坐标
(setq x1 (substr line1 67));读取y坐标
(setq x (distof x1 2));将x，y坐标转换为实数
(setq y (distof y1 2))
(setq basept (list y x));得到左下角实地坐标
(close f1);关闭tfw文件
(vla-AddRaster(vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object))) tifffile (vlax-3d-point basept) sfb1 0);插入图像
(terpri)
(command "zoom" "e");缩放显示
(setq i (+ i 1));循环变量++
);/repeat
(prin1)
)

(defun AddTif ( 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 = \"目录\"; }" 
                        "        : button" 
                        "        {" 
                        "            key = \"brw\";" 
                        "            label = \"浏览\";" 
                        "            fixed_width = true;" 
                        "        }" 
                        "    }" 
                        "    spacer;" 
                        "    : row" 
                        "    {" 
                        "        : column" 
                        "        {" 
                        "            : lst { key = \"box1\"; }" 
                        "            : but { key = \"add\" ; label = \"添加文件\"; }" 
                        "        }" 
                        "        : column {" 
                        "            : lst { key = \"box2\"; }" 
                        "            : but { key = \"del\" ; label = \"移除文件\"; }" 
                        "        }" 
                        "    }" 
                        "    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 "")) "文件选择 BY END." 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 
    (yxpj 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) 
) 
 
(princ) 
 
 
(defun yxpj ( tiflist / tifffile tifffilename lujing f1 fb1 xs txkd sdj1 sfb1 basept y1 y x1 x line1 i j) 
    (vl-load-com) 
 
    (setq i 0);初始化循环变量 
    (setq j 0) 
    (repeat (length tiflist) 
        (setq tifffile (nth i tiflist)) 
         
        (setq tifffilename(strcat (vl-filename-base tifffile) ".tfw")) 
        (setq lujing(strcat (vl-filename-directory tifffile) "\\" tifffilename));生成影像图和TFW文件路径 
         
        (setq f1 (open lujing "r")) 
        (setq line1 (read-line f1));读取tfw文件 
        (setq fb1 (substr line1 1 12)) 
 
        (while(= j 0) 
            (setq txkd 1) 
            (prompt "\n 输入图像宽度的像素尺寸：") 
            (setq xs (getreal));用户输入数据 
            (setq sdj1 (* (distof fb1 2) xs));计算图像宽度的实地距离 
            (setq sfb1 (/ sdj1 txkd));计算缩放比例 
            (prompt "\n 缩放比例为：") 
            (princ sfb1) 
            (setq j 1) 
        );/while 
 
        (setq y1 (substr line1 50 17));读取x坐标 
        (setq x1 (substr line1 67));读取y坐标 
         
        (setq x (distof x1 2));将x，y坐标转换为实数 
        (setq y (distof y1 2)) 
         
        (setq basept (list y x));得到左下角实地坐标 
         
        (close f1);关闭tfw文件 
 
        (vla-AddRaster(vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object))) tifffile (vlax-3d-point basept) sfb1 0);插入图像 
        (terpri) 
        (command "zoom" "e");缩放显示 
         
        (setq i (+ i 1));循环变量++ 
    );/repeat 
         
    (prin1) 
    
)

Lisphk · 发表于 2018-3-22 09:56:28

楼主，执行的命令名是什么？

tjmxyz · 发表于 2018-3-22 14:25:51

使用方法:
(AddTif "" "路径" "文件格式")
示例:
(AddTif "" "D:\" "TIF")

复制代码

tjmxyz · 发表于 2018-3-22 14:27:03

Lisphk 发表于 2018-3-22 09:56

使用方法:
(AddTif "" "路径" "文件格式")
示例:
(AddTif "" "D:\\" "TIF")

liunian0524 · 发表于 2018-3-29 08:26:54

感谢分享,,,,

依然小小鸟 · 发表于 2018-3-29 08:30:42

liunian0524 发表于 2018-3-29 08:26
感谢分享,,,,

怎么用啊我新手

柴月二号 · 发表于 2018-3-31 19:49:29

输入像素尺寸以后就报错了

tjmxyz · 发表于 2018-4-2 09:30:36

依然小小鸟发表于 2018-3-29 08:30
怎么用啊我新手

(AddTif \"\" \"路径\" \"文件格式\")\n")

qingchao · 发表于 2018-5-10 15:19:06

这个显的有点麻烦了！

qingchao · 发表于 2018-5-11 09:28:33

tjmxyz 发表于 2018-3-22 14:25

还是做成命令用起来比较方便

kqqt6236 · 发表于 2018-5-11 10:11:19

不错，不错。

sicky111 · 发表于 2018-7-6 01:47:58

谢谢分享。

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

[每日一码] 批量加载TIF格式影像文件

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

评分

点评