TA的每日心情![](source/plugin/dsu_paulsign/img/emot/kx.gif) | 开心 2024-8-31 15:58 |
---|
签到天数: 89 天 [LV.6]常住居民II
管理员
- 积分
- 3366
|
(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")
)
) |
|