最简单的服务器登录授权示例

dcl1214 · 发表于 2024-4-14 21:01:23

本帖最后由 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
(print
"操作系统安装有问题,无法创建对象“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_dcl dcl_id dhkwz 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)
)
(if s
(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$))

(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 
      (print 
  "操作系统安装有问题,无法创建对象“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_dcl  dcl_id  dhkwz   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) 
    ) 
    (if  s 
      (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$))

知者无疆 · 发表于 2024-4-14 22:33:25

请问下：具体怎么用？

boboxiake · 发表于 2024-4-15 11:17:25

首先得有个自己的服务器吧？

账号		自动登录	找回密码
密码			注册

最简单的服务器登录授权示例

本帖子中包含更多资源

评分