压缩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)
)

e2002

缺少函数：
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    105  110  116  101         114  110  0
            108         112  112  45        115  121  109  102  117         110  45   62
            97         108  0           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 [int 一个字节字符串转10进制整数] [对象 打开的文件标识])
(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))

pxt2001

光压缩没意思，还需要解压缩