跪求同TWF文件导入TIF到CAD的源代码
前面看有个前辈写了一个这个程序，但用后发现图片例大了一倍，而且是封装过的，哪位大神有这个程序的源码能不能共享下啊GeoRefImg，这个是插入带座标图片的檔案，可以到下面的连结看一下！
不是批次的！
http://www.cadstudio.cz/georefimg
下面的代码如果worldfile的x旋转量及y旋转量不为0的话会跟GeoRefImg套出来的结果不同。;;; AUTHOR
;;; Copyrightc 2011 Ron Perez (ronperez AT gmail DOT com)
;;;
;;;Reads world tiff file (.tfw) to scale and place image correctly in autocad.
;;;First insert all tiff images into drawing at whatever scale and insertion point.
;;;If the TFW exists in same directory and is named the same as the image selected,
;;;it will automatically be found and the image will be scaled and placed. If it is
;;;not in the same directory it can be browsed to.
;;;03.23.2011 Added support to create TFW files as well as support rotated images :)
;;;10.11.2011 *BUG FIX* Basepoint was off 1/2 the pixel resolution DOH!
;;;Needs a file with 6 lines (ScaleX Rotation -Rotation -ScaleY TopLeftXCoord TopLeftYCoord)
(defun c:tfw (/ ss->lst foo _readfile _writetofile bpt
data ext hgt hs imgpath imhgt imwdthl1
mvpt name opt pre rot ss tfw wdth
)
(vl-load-com)
(defun ss->lst (ss / e n out)
(setq n -1)
(while (setq e (ssname ss (setq n (1+ n))))
(setq out (cons (vlax-ename->vla-object e) out))
)
)
(defun _writetofile (filename lst / file result)
(cond ((and (eq 'str (type filename)) (setq file (open filename "w")))
(foreach x lst
(write-line
(cond ((= (type x) 'str) x)
((= (type x) 'int) (itoa x))
((= (type x) 'real) (rtos x 2 16))
((vl-prin1-to-string x))
)
file
)
)
(close file)
filename
)
)
)
(defun _readfile (filename / file line result)
(cond
((and (eq 'str (type filename)) (setq file (open filename "r")))
(while (setq line (read-line file))
(setq result (cons (vl-string-trim " " line) result))
)
(close file)
(reverse result)
)
)
)
(defun foo (file / ext)
(if (setq ext (strcase (vl-filename-extension file) t))
(cond ((wcmatch ext ".tif*") ".tfw")
((wcmatch ext ".jp*g") ".jgw")
((eq ext ".png") ".pgw")
)
)
)
(setq opt "ReadIt")
(initget 0 "ReadIt WriteIt")
(setq opt
(cond
((getkword (strcat "\nImage World File <" opt ">: "))
)
(opt)
)
)
(princ "\nSelect image(s): ")
(setq pre (getvar 'dwgprefix))
(if (and (setq ss (ssget ":L" '((0 . "image")))) (setq ss (ss->lst ss)))
(foreach image ss
(setq name (vlax-get image 'name)
hgt (vlax-get image 'height)
wdth (vlax-get image 'width)
imhgt (vlax-get image 'imageheight)
imwdth(vlax-get image 'imagewidth)
rot (vlax-get image 'rotation)
bpt (vlax-get image 'origin)
imgpath (vlax-get image 'imagefile)
ext (foo imgpath)
imgpath (vl-filename-directory imgpath)
tfw (strcat imgpath "\\" name ext)
)
(if (= opt "ReadIt")
(progn
(if
(and
(or
(findfile tfw)
(setq tfw (findfile (strcat pre name ext)))
(setq tfw (getfiled (strcat "***Select <<" name ext ">>***")
pre
(substr ext 2)
16
)
)
)
(setq data (mapcar 'atof (_readfile tfw)))
(> (length data) 5)
(setq l1 (abs (car data)))
(setq hs (* l1 0.5))
(setq mvpt (list (nth 4 data) (nth 5 data) 0.0))
)
(progn (vla-put-imageheight image (* hgt l1))
(vla-put-imagewidth image (* wdth l1))
(vla-put-rotation image (cadr data))
(setq rot (vlax-get image 'rotation))
(setq bpt (polar bpt (+ (/ pi 2.) rot) (* hgt l1)))
;;Basepoint offset since it's the CENTER of the upper left pixel
(setq bpt (list (+ (car bpt) hs) (- (cadr bpt) hs) 0.0))
(vlax-invoke image 'move bpt mvpt)
(princ (strcat "\nTFW File Read - " tfw))
)
(princ "\nTFW file NOT found or not correctly formatted!")
)
)
(progn (setq bpt (polar bpt (+ (/ pi 2.) rot) imhgt))
(setq hs (* (abs (/ imhgt hgt)) 0.5))
;;Basepoint offset since it's the CENTER of the upper left pixel
(setq bpt (list (+ (car bpt) hs) (- (cadr bpt) hs) 0.0))
(if (setq tfw (_writetofile
(if (findfile (strcat imgpath "\\" name ext))
(strcat imgpath "\\" name ext)
(strcat pre name ext)
)
(list (/ imhgt hgt)
rot
(- (abs rot))
(- (abs (/ imwdth wdth)))
(car bpt)
(cadr bpt)
)
)
)
(alert (princ tfw))
(alert (strcat "\n!!Error writing file... " tfw))
)
)
)
)
)
(princ)
) 谢谢楼上,先收藏了.
用AutoDesk Raster Design可在cad中方便的插入对应tfw坐标的图片.
页:
[1]