明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1406|回复: 2

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

[复制链接]
发表于 2024-4-14 21:01:23 | 显示全部楼层 |阅读模式
本帖最后由 dcl1214 于 2024-4-14 21:11 编辑

更加详细的工程管理见附件zip文件包
  1. (vl-doc-export '$c:loginrun$)
  2. (defun $http$
  3.        (host post?get body lst / $send$ http rt v-t PN $xmlhttp$)
  4.   (DEFUN $xmlhttp$ (lst)
  5.     (cond
  6.       ((and (= (getenv "zx-xmlhttp") "1")
  7.       (setq objHttp (vlax-create-object "Msxml2.XMLHTTP"))
  8.           ;有缓存速度快,用这个的时候,报文头里面如果有中文,服务器不会乱码
  9.        )
  10.        t
  11.       )
  12.       ((and (= (getenv "zx-xmlhttp") "2")
  13.       (setq objHttp (vlax-create-object "Microsoft.XMLHTTP"))
  14.           ;这个是2.0的
  15.        )
  16.        t
  17.       )
  18.       ((and (= (getenv "zx-xmlhttp") "3")
  19.       (setq
  20.         objHttp (vlax-create-object "winhttp.winhttprequest.5.1")
  21.       )
  22.           ;这个没用过,先记录这里
  23.        )
  24.        t
  25.       )
  26.       ((and (= (getenv "zx-xmlhttp") "4")
  27.       (setq objHttp (vlax-create-object "Msxml2.ServerXMLHTTP"))
  28.           ;没有缓存,报文头里面如果有中文服务器会乱码
  29.        )
  30.        t
  31.       )
  32.       (t
  33.        (setq objHttp (vlax-create-object "Msxml2.XMLHTTP"))
  34.           ;有缓存速度快,用这个的时候,报文头里面如果有中文,服务器不会乱码
  35.       )
  36.     )
  37.     objHttp
  38.   )
  39.   (defun $send$
  40.     (http / value err-str send-zt GUID)
  41.     (SETQ PN (reg-read "LOGIN" "PN"))
  42.     (vl-catch-all-apply
  43.       'vlax-invoke-method
  44.       (list http
  45.       "setRequestHeader"
  46.       "Content-Length"
  47.       ""
  48.       )
  49.     )
  50.     (AND PN
  51.    (vl-catch-all-apply
  52.      'vlax-invoke-method
  53.      (list http
  54.      "setRequestHeader"
  55.      "Client-Auth"
  56.      (strcat pn
  57.        "|"
  58.        (apply
  59.          'strcat
  60.          (mapcar
  61.            'vl-princ-to-string
  62.            (vl-string->list (getenv "ComputerName"))
  63.          )
  64.        )
  65.      )
  66.      )
  67.    )
  68.     )
  69.     (vl-catch-all-apply
  70.       'vlax-invoke-method
  71.       (list http
  72.       "setRequestHeader"
  73.       "CONTENT-TYPE"
  74.       "text/plain"
  75.       )
  76.     )
  77.     (if  (SETQ GSM (getenv "ZX-GSM"))
  78.       (vl-catch-all-apply
  79.   'vlax-invoke-method
  80.   (list http
  81.         "setRequestHeader"
  82.         "company"
  83.         GSM
  84.   )
  85.       )
  86.     )          ;公司名发送过去
  87.     (if  (SETQ GUID (REG-READ "GUID" "GUID"))
  88.       (vl-catch-all-apply
  89.   'vlax-invoke-method
  90.   (list http
  91.         "setRequestHeader"
  92.         "guid"
  93.         GUID
  94.   )
  95.       )
  96.     )
  97.     (SETQ value
  98.      (vl-catch-all-apply
  99.        'vlax-invoke-method
  100.        (list http "SEND" body)
  101.      )
  102.     )
  103.     (if  (vl-catch-all-error-p value)
  104.       (progn (setq err-str (vl-catch-all-error-message value))
  105.        (print err-str)
  106.        (vlax-release-object http)  ;释放对象
  107.        (setq send-zt nil)    ;如果在发送的过程中出现了意外就将zt做空
  108.       )
  109.       (setq send-zt t)
  110.     )
  111.     send-zt
  112.   )

  113.   (print "http - 0")
  114.   (IF (SETQ http ($xmlhttp$ NIL))
  115.     (PROGN
  116.       (print "http - 1")
  117.       (if (IF (vl-catch-all-error-p
  118.     (SETQ rt
  119.            (vl-catch-all-apply
  120.        'vla-open
  121.        (list http post?get host 0)
  122.            )
  123.     )
  124.         )
  125.       (progn (print (vl-catch-all-error-message rt))
  126.        nil
  127.       )
  128.       t
  129.     )        ;开启
  130.   (PROGN
  131.     (print "http - 3")
  132.     (if ($send$ http)
  133.           ;发送
  134.       (PROGN
  135.         (print "http - 4")
  136.         (while
  137.     (not
  138.       (eq (vlax-get-property http "readyState") 4)
  139.     )
  140.      (repeat 200)
  141.         )
  142.         (if (= (vlax-get-property http "readyState") 4)
  143.     (setq v-t
  144.            (vlax-get-property http 'responseText)
  145.     )
  146.         )
  147.         (print "http - 5")
  148.       )
  149.     )
  150.   )
  151.       )
  152.       (and http
  153.      (vl-catch-all-apply 'vlax-release-object (list http))
  154.       )
  155.     )
  156.     (repeat 10
  157.       (print
  158.   "操作系统安装有问题,无法创建对象“Msxml2.XMLHTTP”"
  159.       )
  160.     )
  161.   )
  162.   (print "http - 7")
  163.   v-t
  164. )
  165. (DEFUN reg-read  (gn key / str ER host)
  166.           ;gn 功能,主要是程序快捷键(注册表里面叫做“项”)
  167.           ;key 字符串
  168.           ;注意:gn和key同时为空的时候返回host主地址
  169.           ;示例(reg-read "JQZF" "dd")
  170.   (setq host "HKEY_CURRENT_USER\\ZXCAD")
  171.   (if (and gn
  172.      key
  173.      (= (type gn) 'str)
  174.      (= (type key) 'str)
  175.      (setq str (vl-registry-read (strcat host "\\" gn) key))
  176.       )
  177.     ()
  178.     (progn
  179.       (IF GN
  180.   (IF (NOT KEY)
  181.     (PRINT "With “GN” and without “key”")
  182.   )
  183.   (PRINT (STRCAT "reg-read ERROR: NOT GN"))
  184.       )
  185.     )
  186.           ;打印一个空的在后面,主要是防止最后一个error被其他程序捕捉到了
  187.   )
  188.   (and (not gn) (not key) (setq str host))
  189.   str
  190. )
  191. (defun reg-write (GN key str)
  192.           ;GN 功能,主要是程序快捷键
  193.           ;key 字符串
  194.           ;str 字符串值
  195.           ;示例:(reg-write NIL "dd" "213")
  196.   (and key
  197.        str
  198.        (= (type key) 'str)
  199.        (vl-registry-write
  200.    (IF GN
  201.      (STRCAT "HKEY_CURRENT_USER\\ZXCAD" "\\" GN)
  202.      "HKEY_CURRENT_USER\\ZXCAD"
  203.    )
  204.    key
  205.    (vl-princ-to-string str)
  206.        )
  207.   )
  208. )
  209. (defun $c:loginrun$ (/        $cs$     $dl$  $mm$   $yhm$
  210.          *error*  _dl_dcl  dcl_id  dhkwz   ip
  211.          mm        startnum userid
  212.         )
  213.   (defun *error* (s) (print))
  214.   (defun _dl_dcl (/ f p lst dcl-n file)
  215.     (setq dcl-n "_dl_dcl")
  216.     (SETQ F (VL-FILENAME-DIRECTORY (VL-FILENAME-MKTEMP)))
  217.     (SETQ P (STRCAT F "\\" DCL-N))
  218.     (if  (findfile p)
  219.       (VL-FILE-DELETE P)
  220.     )
  221.     (setq lst (list
  222.     "dl:dialog {"
  223.     "    label = \"服务器登录\" ;"
  224.     "   key = \"dl\" ;"
  225.     "    :spacer {"
  226.     "        height = 1 ;"
  227.     "    }"
  228.     "    :column {"
  229.     "        height = 5 ;"
  230.     "        label = \"服务器\" ;"
  231.     "        :row {"
  232.     "            :edit_box {"
  233.     "                key = \"ip\" ;"
  234.     "                label = \"ip:\" ;"
  235.     "                width = 60 ;"
  236.     "            }"
  237.     "            :button {"
  238.     "                key = \"cs\" ;"
  239.     "                label = \"测试连接\" ;"
  240.     "            }"
  241.     "        }"
  242.     "        :spacer {}"
  243.     "    }"
  244.     "    :spacer {"
  245.     "        height = 1 ;"
  246.     "    }"
  247.     "    :column {"
  248.     "        height = 5 ;"
  249.     "        label = \"账户信息\" ;"
  250.     "        :row {"
  251.     "            :edit_box {"
  252.     "                key = \"yhm\" ;"
  253.     "                label = \"用户名:\" ;"
  254.     "            }"
  255.     "            :spacer {"
  256.     "                width = 2 ;"
  257.     "            }"
  258.     "            :edit_box {"
  259.     "                key = \"mm\" ;"
  260.     "                label = \"密码:\" ;"
  261.     "                password_char = \"*\" ;"
  262.     "            }"
  263.     "            :button {"
  264.     "                key = \"log\" ;"
  265.     "                label = \"登录\" ;"
  266.     "            }"
  267.     "        }"
  268.     "    }"
  269.     "    :spacer {"
  270.     "        height = 2 ;"
  271.     "    }"
  272.     "    :row {"
  273.     "    :button {"
  274.     "        height = 3 ;"
  275.     "        is_cancel = true ;"
  276.     "        key = \"tc\" ;"
  277.     "        label = \"退出\" ;"
  278.     "    }"
  279.     "        :image {"
  280.     "            is_tab_stop = false ;"
  281.     "            aspect_ratio = 1 ;"
  282.     "            fixed_height = true ;"
  283.     "            fixed_width = true ;"
  284.     "            key = \"logo\" ;"
  285.     "            width = 8.833 ;"
  286.     "            vertical_margin = none ;"
  287.     "            horizontal_margin = none ;"
  288.     "        }"
  289.     "        }"
  290.     "}"
  291.          )
  292.     )
  293.     (setq p nil)
  294.     (setq p (STRCAT f "\\dl.dcl"))
  295.     (if  (setq file (open p "w"))
  296.       (progn
  297.   (foreach line lst
  298.     (write-line line file)
  299.   )
  300.   (close file)
  301.       )
  302.     )
  303.     (if  (findfile p)
  304.       p
  305.       nil
  306.     )
  307.   )
  308.   (defun $yhm$ (/ yhm)
  309.     (setq yhm (get_tile "yhm"))
  310.     (setenv "userid" yhm)
  311.   )
  312.   (defun $mm$ (/ mm)
  313.     (setq mm (get_tile "mm"))
  314.     (setenv "password" mm)
  315.   )
  316.   (defun $cs$ (/ ip host fh s)
  317.     (setq ip (get_tile "ip"))
  318.     (setq ip (strcase ip t))
  319.     (setq host (strcat ip "/test"))
  320.     (setq fh (vl-catch-all-apply
  321.          (function (lambda () ($http$ host "POST" "" lst)))
  322.        )
  323.     )
  324.     (if  (vl-catch-all-error-p fh)
  325.       (setq fh nil)
  326.     )
  327.     (setq s (vl-catch-all-apply 'read (list fh)))
  328.     (if  (vl-catch-all-error-p s)
  329.       (setq s nil)
  330.     )
  331.     (if  s
  332.       (progn (alert "连接成功\n\n请输入下方的账户密码登录")
  333.        (setenv "数据库地址" ip)
  334.       )
  335.     )
  336.   )
  337.   (defun $log$ (/ yhm mm)
  338.     (setq yhm (get_tile "yhm"))
  339.     (setq mm (get_tile "mm"))
  340.     (alert "开发中")
  341.   )





  342. ;;;;;;;;奔跑;;;;;;;;;;;;;;

  343.   (setq dcl_id (load_dialog (_dl_dcl)))
  344.   (setq startNum 2)
  345.   (while (>= startNum 2)
  346.     (setq dhkwz (list -1 -1))
  347.     (new_dialog "dl" dcl_id "" dhkwz)
  348.     (if  (or (setq ip (getenv "数据库地址"))
  349.       (setq ip (setq ip (REG-READ "LOGIN" "ip")))
  350.   )
  351.       (SET_TILE "ip" ip)
  352.     )
  353.     (and (setq userid (getenv "userid"))
  354.    (set_tile "yhm" userid)
  355.     )
  356.     (and (setq mm (getenv "password")) (set_tile "mm" mm))
  357.     (ACTION_TILE "yhm" "($yhm$)")
  358.     (ACTION_TILE "mm" "($mm$)")
  359.     (ACTION_TILE "cs" "($cs$)")
  360.     (ACTION_TILE "log" "($log$)")
  361.     (makelogo "logo")
  362.     (setq startNum (start_dialog))
  363.   )
  364. )
  365. (DEFUN c:login () ($c:loginrun$))

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 1明经币 +1 收起 理由
ssyfeng + 1 赞一个!

查看全部评分

发表于 2024-4-14 22:33:25 | 显示全部楼层
请问下:具体怎么用?
发表于 2024-4-15 11:17:25 | 显示全部楼层
首先得有个自己的服务器吧?
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-12-23 05:31 , Processed in 0.149161 second(s), 24 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表