最简单的服务器登录授权示例
本帖最后由 dcl1214 于 2024-4-14 21:11 编辑更加详细的工程管理见附件zip文件包
(vl-doc-export '$c:loginrun$)
(defun $http$
(host post?get body lst / $send$ http rt v-t PN $xmlhttp$)
(DEFUN $xmlhttp$ (lst)
(cond
((and (= (getenv "zx-xmlhttp") "1")
(setq objHttp (vlax-create-object "Msxml2.XMLHTTP"))
;有缓存速度快,用这个的时候，报文头里面如果有中文，服务器不会乱码
)
t
)
((and (= (getenv "zx-xmlhttp") "2")
(setq objHttp (vlax-create-object "Microsoft.XMLHTTP"))
;这个是2.0的
)
t
)
((and (= (getenv "zx-xmlhttp") "3")
(setq
objHttp (vlax-create-object "winhttp.winhttprequest.5.1")
)
;这个没用过，先记录这里
)
t
)
((and (= (getenv "zx-xmlhttp") "4")
(setq objHttp (vlax-create-object "Msxml2.ServerXMLHTTP"))
;没有缓存，报文头里面如果有中文服务器会乱码
)
t
)
(t
(setq objHttp (vlax-create-object "Msxml2.XMLHTTP"))
;有缓存速度快,用这个的时候，报文头里面如果有中文，服务器不会乱码
)
)
objHttp
)
(defun $send$
(http / value err-str send-zt GUID)
(SETQ PN (reg-read "LOGIN" "PN"))
(vl-catch-all-apply
'vlax-invoke-method
(list http
"setRequestHeader"
"Content-Length"
""
)
)
(AND PN
(vl-catch-all-apply
'vlax-invoke-method
(list http
"setRequestHeader"
"Client-Auth"
(strcat pn
"|"
(apply
'strcat
(mapcar
'vl-princ-to-string
(vl-string->list (getenv "ComputerName"))
)
)
)
)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list http
"setRequestHeader"
"CONTENT-TYPE"
"text/plain"
)
)
(if(SETQ GSM (getenv "ZX-GSM"))
(vl-catch-all-apply
'vlax-invoke-method
(list http
"setRequestHeader"
"company"
GSM
)
)
) ;公司名发送过去
(if(SETQ GUID (REG-READ "GUID" "GUID"))
(vl-catch-all-apply
'vlax-invoke-method
(list http
"setRequestHeader"
"guid"
GUID
)
)
)
(SETQ value
(vl-catch-all-apply
'vlax-invoke-method
(list http "SEND" body)
)
)
(if(vl-catch-all-error-p value)
(progn (setq err-str (vl-catch-all-error-message value))
(print err-str)
(vlax-release-object http);释放对象
(setq send-zt nil) ;如果在发送的过程中出现了意外就将zt做空
)
(setq send-zt t)
)
send-zt
)
(print "http - 0")
(IF (SETQ http ($xmlhttp$ NIL))
(PROGN
(print "http - 1")
(if (IF (vl-catch-all-error-p
(SETQ rt
(vl-catch-all-apply
'vla-open
(list http post?get host 0)
)
)
)
(progn (print (vl-catch-all-error-message rt))
nil
)
t
) ;开启
(PROGN
(print "http - 3")
(if ($send$ http)
;发送
(PROGN
(print "http - 4")
(while
(not
(eq (vlax-get-property http "readyState") 4)
)
(repeat 200)
)
(if (= (vlax-get-property http "readyState") 4)
(setq v-t
(vlax-get-property http 'responseText)
)
)
(print "http - 5")
)
)
)
)
(and http
(vl-catch-all-apply 'vlax-release-object (list http))
)
)
(repeat 10
"操作系统安装有问题,无法创建对象“Msxml2.XMLHTTP”"
)
)
)
(print "http - 7")
v-t
)
(DEFUN reg-read(gn key / str ER host)
;gn 功能，主要是程序快捷键（注册表里面叫做“项”）
;key 字符串
;注意：gn和key同时为空的时候返回host主地址
;示例(reg-read "JQZF" "dd")
(setq host "HKEY_CURRENT_USER\\ZXCAD")
(if (and gn
key
(= (type gn) 'str)
(= (type key) 'str)
(setq str (vl-registry-read (strcat host "\\" gn) key))
)
()
(progn
(IF GN
(IF (NOT KEY)
(PRINT "With “GN” and without “key”")
)
(PRINT (STRCAT "reg-read ERROR: NOT GN"))
)
)
;打印一个空的在后面,主要是防止最后一个error被其他程序捕捉到了
)
(and (not gn) (not key) (setq str host))
str
)
(defun reg-write (GN key str)
;GN 功能，主要是程序快捷键
;key 字符串
;str 字符串值
;示例：(reg-write NIL "dd" "213")
(and key
str
(= (type key) 'str)
(vl-registry-write
(IF GN
(STRCAT "HKEY_CURRENT_USER\\ZXCAD" "\\" GN)
"HKEY_CURRENT_USER\\ZXCAD"
)
key
(vl-princ-to-string str)
)
)
)
(defun $c:loginrun$ (/ $cs$ $dl$$mm$ $yhm$
*error*_dl_dcldcl_iddhkwz ip
mm startnum userid
)
(defun *error* (s) (print))
(defun _dl_dcl (/ f p lst dcl-n file)
(setq dcl-n "_dl_dcl")
(SETQ F (VL-FILENAME-DIRECTORY (VL-FILENAME-MKTEMP)))
(SETQ P (STRCAT F "\\" DCL-N))
(if(findfile p)
(VL-FILE-DELETE P)
)
(setq lst (list
"dl:dialog {"
" label = \"服务器登录\" ;"
" key = \"dl\" ;"
" :spacer {"
" height = 1 ;"
" }"
" :column {"
" height = 5 ;"
" label = \"服务器\" ;"
" :row {"
" :edit_box {"
" key = \"ip\" ;"
" label = \"ip：\" ;"
" width = 60 ;"
" }"
" :button {"
" key = \"cs\" ;"
" label = \"测试连接\" ;"
" }"
" }"
" :spacer {}"
" }"
" :spacer {"
" height = 1 ;"
" }"
" :column {"
" height = 5 ;"
" label = \"账户信息\" ;"
" :row {"
" :edit_box {"
" key = \"yhm\" ;"
" label = \"用户名：\" ;"
" }"
" :spacer {"
" width = 2 ;"
" }"
" :edit_box {"
" key = \"mm\" ;"
" label = \"密码：\" ;"
" password_char = \"*\" ;"
" }"
" :button {"
" key = \"log\" ;"
" label = \"登录\" ;"
" }"
" }"
" }"
" :spacer {"
" height = 2 ;"
" }"
" :row {"
" :button {"
" height = 3 ;"
" is_cancel = true ;"
" key = \"tc\" ;"
" label = \"退出\" ;"
" }"
" :image {"
" is_tab_stop = false ;"
" aspect_ratio = 1 ;"
" fixed_height = true ;"
" fixed_width = true ;"
" key = \"logo\" ;"
" width = 8.833 ;"
" vertical_margin = none ;"
" horizontal_margin = none ;"
" }"
" }"
"}"
)
)
(setq p nil)
(setq p (STRCAT f "\\dl.dcl"))
(if(setq file (open p "w"))
(progn
(foreach line lst
(write-line line file)
)
(close file)
)
)
(if(findfile p)
p
nil
)
)
(defun $yhm$ (/ yhm)
(setq yhm (get_tile "yhm"))
(setenv "userid" yhm)
)
(defun $mm$ (/ mm)
(setq mm (get_tile "mm"))
(setenv "password" mm)
)
(defun $cs$ (/ ip host fh s)
(setq ip (get_tile "ip"))
(setq ip (strcase ip t))
(setq host (strcat ip "/test"))
(setq fh (vl-catch-all-apply
(function (lambda () ($http$ host "POST" "" lst)))
)
)
(if(vl-catch-all-error-p fh)
(setq fh nil)
)
(setq s (vl-catch-all-apply 'read (list fh)))
(if(vl-catch-all-error-p s)
(setq s nil)
)
(ifs
(progn (alert "连接成功\n\n请输入下方的账户密码登录")
(setenv "数据库地址" ip)
)
)
)
(defun $log$ (/ yhm mm)
(setq yhm (get_tile "yhm"))
(setq mm (get_tile "mm"))
(alert "开发中")
)
;;;;;;;;奔跑;;;;;;;;;;;;;;
(setq dcl_id (load_dialog (_dl_dcl)))
(setq startNum 2)
(while (>= startNum 2)
(setq dhkwz (list -1 -1))
(new_dialog "dl" dcl_id "" dhkwz)
(if(or (setq ip (getenv "数据库地址"))
(setq ip (setq ip (REG-READ "LOGIN" "ip")))
)
(SET_TILE "ip" ip)
)
(and (setq userid (getenv "userid"))
(set_tile "yhm" userid)
)
(and (setq mm (getenv "password")) (set_tile "mm" mm))
(ACTION_TILE "yhm" "($yhm$)")
(ACTION_TILE "mm" "($mm$)")
(ACTION_TILE "cs" "($cs$)")
(ACTION_TILE "log" "($log$)")
(makelogo "logo")
(setq startNum (start_dialog))
)
)
(DEFUN c:login () ($c:loginrun$))
请问下：具体怎么用？ 首先得有个自己的服务器吧？:lol
页:
[1]