[函数] Lisp执行post上传文件到远程服务器

admin1

(defun $upload$  (loc      target     lst    /       adostream
     err?      err-str    jgs    objhttp
     return-value         status    url       value-text
     size      header-vaule    REG       IP
    )
          ;二进制流的方式上传文件
          ;服务器的GO语言程序server必须是V16版本以上
  (if (and loc (setq size (vl-file-size loc)) target)
    (PROGN
      (IF (setq reg (reg-read "login" "PN"))
  (setq header-vaule
         (strcat
     reg
     "|"
     (apply
       'strcat
       (mapcar
         'vl-princ-to-string
         (vl-string->list (getenv "ComputerName"))
       )
     )
         )
  )
  (SETQ header-vaule (getenv "ComputerName"))
      )
      (OR (setq ip (cdr (assoc "IP" LST)))
    (SETQ IP (getenv "数据库地址"))
      )
      (OR (setq PORT (cdr (assoc "端口号" LST)))
    (SETQ PORT "80")
      )
      (OR (setq func (cdr (assoc "接口" LST)))
    (setq func ($fu-wu-qi-jie-kou$ "上传文件"))
    (SETQ func "upload")
      )
      (and ip
     port
     func
     (setq url (strcat IP ":" port "/" func)
     )
      )
      (cond
  ((not (setq ADOStream (vl-catch-all-apply
        'vlax-create-object
        (list "ADODB.Stream")
            )
        )
   )
   (princ "\n无法创建adodb.stream")
   (setq status nil)
  )
  ((or
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-put-property
          (list ADOStream 'type 1)
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke
          (list ADOStream 'open)
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-put-property
          (list ADOStream 'Position 0)
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke-method
          (list ADOStream 'LoadFromFile loc)
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-put-property
          (list ADOStream 'Position 0)
        )
       )
     )
   )
   (princ (vl-catch-all-error-message return-value))
   (princ "\n设置adostream失败")
   (setq status nil)
   (vlax-release-object ADOStream)
  )
  ((not (setq objHttp (vlax-create-object "Msxml2.XMLHTTP")))
   (princ "\n无法创建对象\"Msxml2.XMLHTTP\"")
   (setq status nil)
  )
  ((vl-catch-all-error-p
     (setq return-value
      (vl-catch-all-apply
        'vla-open
        (list objHttp "POST" url 0)
      )
     )
   )
   (princ (vl-catch-all-error-message return-value))
   (princ "\n无法到达远程主机")
   (setq status nil)
   (vlax-release-object objHttp)
  )
  ((or
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke-method
          (list objHttp
          "setRequestHeader"
          "Upload-Filename"
          target
          )
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke-method
          (list objHttp
          "setRequestHeader"
          "Content-Type"
          "application/octet-stream"
          )
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke-method
          (list objHttp
          "setRequestHeader"
          ($fu-wu-qi-jie-kou$ "报文头标题")
          header-vaule
          )
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke-method
          (list objHttp
          "setRequestHeader"
          "Response-Charset"
          "UTF8"
          )
        )
       )
     )
     (vl-catch-all-error-p
       (setq return-value
        (vl-catch-all-apply
          'vlax-invoke-method
          (list objHttp "send" ADOStream)
        )
       )
     )
   )
   (princ (vl-catch-all-error-message return-value))
   (princ "\n无法与远程主机建立联系")
   (setq status nil)
   (vlax-release-object objHttp)
  )
  ((progn
     (vl-catch-all-apply
       'vlax-invoke-method
       (list ADOStream 'close)
     )        ;关闭文件流
     (if ADOStream
       (vlax-release-object ADOStream)
     )
     (while (not (eq (vlax-get-property objHttp "readyState") 4))
       (repeat 100)
     )
     (/= (vlax-get-property objHttp "readyState") 4)
   )
   (princ "\n与远程主机联系异常")
   (setq status nil)
   (vlax-release-object objHttp)
  )
  (t
   (progn
     (and
       (setq value-text
        (vlax-get-property objHttp 'responseText)
       )
          ;直接让系统ado组件返回text格式
       (setq status t)
     )
     (vlax-release-object objHttp)
     (IF (and (setq err? nil
        err? (vl-catch-all-apply
         'read
         (list (STRCAT "'(" value-text ")"))
             )
        )
        (not (vl-catch-all-error-p err?))
         )
       (progn
         (setq jgs
          (car (car (EVAL (READ (STRCAT "'(" value-text ")"))))
          )
         )
         (AND jgs
        (= (TYPE jgs) 'LIST)
        (= (TYPE (CAR jgs)) 'LIST)
        (setq jgs
         (reverse
           (cons (cons "size-loc" (vl-princ-to-string size))
           (reverse jgs)
           )
         )
        )
         )
       )
       (progn
         (and err?
        (setq err-str (vl-catch-all-error-message err?))
         )
         (and err-str (print err-str))
         (and
     err-str
     (blsc value-text
           (strcat "数据库返回有问题_" err-str ".TXT")
     )
         )
       )
     )
     (IF (AND jgs
        (= (TYPE jgs) 'LIST)
        (= (TYPE (CAR jgs)) 'LIST)
        (= (TYPE (CAR (CAR jgs))) 'STR)
         )
       ()
       (SETQ JGS NIL)
     )
   )
  )
      )
    )
    (alert "上传文件的参数不能为空！")
  )
  jgs
)


($upload$ "C:\\Users\\dcl\\Desktop\\11.png"
    "22"
    (list  (cons "IP" "http://cadx.top")
    (cons "端口" "8088")
    (cons "接口" "img")
    )
)