压缩zip文件函数
;压缩文件函数;zipfile 目标zip文件名
;filelst 需要压缩的文件名表
(defun N5-zipfile (zipfile filelst / fo
objFSO objshell zipobject zipfilescount
)
(if (findfile zipfile)
(vl-file-delete zipfile)
)
(if (not (findfile zipfile))
(progn
(setq fo (open zipfile "w"))
(FOREACH A
(BYTESTO10 "504B0506000000000000000000000000000000000000"
)
(WRITE-BYTE A FO)
)
(close fo)
)
)
(setq objFSO (vlax-create-object "Scripting.FileSystemObject"))
(setq objshell (vlax-create-object "Shell.Application"))
(setq zipobject (vlax-invoke objshell 'NameSpace zipfile))
(setq zipfilescount 0)
(FOREACH file filelst
(if (findfile file)
(vlax-invoke zipobject 'CopyHere file)
)
(while (= (vlax-get-property (vlax-invoke zipobject 'items) 'count)
zipfilescount
)
(command "delay" 100)
)
(setq zipfilescount (1+ zipfilescount))
)
(vlax-release-object objFSO)
(vlax-release-object objshell)
)
缺少函数：
BYTESTO10
WRITE-BYTE
e2002 发表于 2024-7-5 14:33
缺少函数：
BYTESTO10
WRITE-BYTE
;;;=============================================================
;;; 程序加载后，就可以用tranf来激活一个系统隐藏的函数
;;; 用法：(tranf "内部函数名")
;;; 参数：函数名的字符串
;;; 返回：T存在或者是可用的内部函数，nil不存在或则无效
;;; 作者：highflybird
;;; 例子：(tranf "get-logical-drives")
;;; 此程序得到网友baitang36和不死猫的大力帮助，特此致谢！
;;; 另外借鉴了tryhi和其他网友的代码，在此一并感谢！
;;;-------------------------------------------------------------
(vl-load-com)
(defun HFB-LOAD-TRANF (/ f o l s b)
(setq o (strcat (getenv "UserProfile") "\\Intern.fas"))
(if (findfile o)
(vl-file-delete o)
)
(setq l '(70 65 83 52 45 70 73 76 69 13 49 13
49 32 36 1 36 51 51 32 48 32 36 86
58 76 80 80 0 105110116101 1141100
108 11211245 115121109102117 11045 62
97 1080 0 57 3 0 22 36
)
)
(setq b (vlax-make-safearray 17 (cons 0 (1- (length l)))))
(vlax-safearray-fill b l)
(setq s (vlax-create-object "ADODB.Stream"))
(vlax-put s 'type 1)
(vlax-invoke s 'open)
(vlax-invoke-method s 'Write b)
(vlax-invoke s 'saveToFile o 2)
(vlax-invoke s 'close)
(vlax-release-object s)
(mapcar
'set
'(:lpp intern lpp-symfun->al)
(mapcar 'eval (load o))
)
(vl-file-delete o)
(defun tranf (s) (lpp-symfun->al (intern s :lpp)))
(tranf 'al-add-subr-name)
(mapcar
'al-add-subr-name
'(al-add-subr-name lpp-symfun->al intern tranf)
)
(if lpp-symfun->al
(princ "\n已打开内部函数转普通函数大门.\n")
(princ "\n激活内部函数转普通函数失败!\n")
)
)
;激活内部函数，(write-byte [对象 打开的文件标识])
(tranf "write-byte")
;字符串分段函数
;参数 str 类型sting
;参数 dimod 当dimod为int时,按int分割(string-Split "asfsgsb" 2)-> '( "as" "fs" gs" b")
;参数 dimod 当dimod为string时,按string 分割(string-Split "assfssgssb" "ss" )-> '( "a" "f" g" b")
(defun string-Split (str dimod / str dimod n nlst)
(if (= (TYPE dimod) 'INT)
(progn
(setq n 1
nlst nil
)
(while (<= n (strlen STR))
(setq nlst (cons (substr str n dimod) nlst))
(setq n (+ n dimod))
)
(reverse nlst)
)
(progn
(while (setq n (vl-string-search dimod str))
(setq nlst (cons (substr str 1 n) nlst)
str(substr str (+ 1 (strlen dimod) n))
)
)
(reverse (cons str nlst))
)
)
)
;多字节字符串转10进制
(DEFUN bytesto10(str)
(setq lst (mapcar 'byteto10 (string-Split str 2)))
) e2002 发表于 2024-7-5 14:33
缺少函数：
BYTESTO10
WRITE-BYTE
这样替换就不用加载我那两个函数了
(FOREACH A
(BYTESTO10 "504B0506000000000000000000000000000000000000"
)
(WRITE-BYTE A FO)
)
=》(foreach a '(80 75 5 6 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255)(write-char a fo)) 光压缩没意思，还需要解压缩
页:
[1]