设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 81|回复: 3

[源码] LISP通过ADO方法连接数据库

[复制链接]
发表于 5 天前 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

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

x
  1. (progn
  2. ;|
  3. ($ado-sqlite-import$)
  4. (setq db-path ($db-path$))    ;数据库地址
  5. (setq con-str ($ConnectString$ db-path)) ;连接字串
  6. (mapcar  'set
  7.   (list 'conn 'RecordSet)
  8.   ($ado-sqlite-open$ con-str "" "")
  9. )          ;开启对象
  10. ($ado-sqlite-do-sql$ conn RecordSet "select * from fj") ;执行sql
  11. (setq fields ($ado-sqlite-getfields$ RecordSet))
  12. (setq rows ($ado-sqlite-getrows$ RecordSet))
  13. (setq data(cons fields rows))
  14. ($ado-sqlite-close$ RecordSet)    ;关闭对象
  15. ($ado-sqlite-close$ conn)    ;关闭对象
  16. ($ado-sqlite-release$ RecordSet)  ;释放对象
  17. ($ado-sqlite-release$ conn)    ;释放对象|;
  18.   (defun $ConnectString$ (db-path)
  19.           ;连接字串
  20.     (strcat
  21.       "Driver={SQLite3 ODBC Driver};Database="
  22.       db-path
  23.     )
  24.   )

  25.   (defun $ado-sqlite-open$ (ConnectString UserName Password)
  26.           ;打开数据库
  27.     (setq conn (vl-catch-all-apply
  28.      'vlax-create-object
  29.      (list "Adodb.Connection")
  30.          )
  31.     )
  32.     (setq rs (vl-catch-all-apply
  33.          'vlax-create-object
  34.          (list "ADODB.RecordSet")
  35.        )
  36.     )
  37.     (if  (not (vl-catch-all-error-p conn))
  38.       (setq obj  (vl-catch-all-apply
  39.       'vlax-invoke-method
  40.       (list
  41.         conn       "Open"
  42.         ConnectString     UserName
  43.         Password
  44.         ADOConstant-adConnectUnspecified
  45.        )
  46.     )
  47.       )
  48.     )
  49.     (if  (not (vl-catch-all-error-p obj))
  50.       (list conn rs)
  51.     )
  52.   )
  53.   (defun $ado-sqlite-close$ (conn?RecordSet)
  54.           ;关闭
  55.     (vl-catch-all-apply
  56.       'vlax-invoke-method
  57.       (list conn?RecordSet "Close")
  58.     )
  59.   )
  60.   (defun $ado-sqlite-release$ (conn?RecordSet)
  61.           ;释放
  62.     (vl-catch-all-apply
  63.       'vlax-release-object
  64.       (list conn?RecordSet)
  65.     )
  66.   )
  67.   (defun $ado-sqlite-import$ (/ ado-p)
  68.           ;引入ado
  69.     (if  (null ADOMethod-Append)
  70.       (cond
  71.   ((and (setq ado-p
  72.          (vl-registry-read
  73.            "HKEY_CLASSES_ROOT\\ADODB.Command\\CLSID"
  74.          )
  75.         )
  76.         (setq ado-p
  77.          (vl-registry-read
  78.            (strcat "HKEY_CLASSES_ROOT\\CLSID\\"
  79.              ado-p
  80.              "\\InProcServer32"
  81.            )
  82.          )
  83.         )
  84.         (progn
  85.     (if (listp ado-p)
  86.       (setq ado-p (cdr ado-p))
  87.     )
  88.     (findfile ado-p)
  89.         )
  90.    )
  91.    (vlax-import-type-library
  92.      :tlb-filename  ado-p
  93.      :methods-prefix  "ADOMethod-"
  94.      :properties-prefix  "ADOProperty-"
  95.      :constants-prefix  "ADOConstant-"
  96.     )
  97.   )
  98.   ((setq ado-p
  99.     (findfile
  100.       (if (getenv "systemdrive")
  101.         (strcat
  102.           (getenv "systemdrive")
  103.           "\\program files\\common files\\system\\ado\\msado15.dll"
  104.         )
  105.         "c:\\program files\\common files\\system\\ado\\msado15.dll"
  106.       )
  107.     )
  108.    )
  109.    (vlax-import-type-library
  110.      :tlb-filename  ado-p
  111.      :methods-prefix  "ADOMethod-"
  112.      :properties-prefix  "ADOProperty-"
  113.      :constants-prefix  "ADOConstant-"
  114.     )
  115.   )
  116.   (if
  117.    (null ADOMethod-Append)
  118.    (cond
  119.      ((and (setq ado-p
  120.       (vl-registry-read
  121.         "HKEY_CLASSES_ROOT\\ADODB.Command\\CLSID"
  122.       )
  123.      )
  124.      (setq ado-p
  125.       (vl-registry-read
  126.         (strcat "HKEY_CLASSES_ROOT\\CLSID\\"
  127.           ado-p
  128.           "\\InProcServer32"
  129.         )
  130.       )
  131.      )
  132.      (progn
  133.        (if (listp ado-p)
  134.          (setq ado-p (cdr ado-p))
  135.        )
  136.        (findfile ado-p)
  137.      )
  138.       )
  139.       (vlax-import-type-library
  140.         :tlb-filename     ado-p
  141.         :methods-prefix     "ADOMethod-"
  142.         :properties-prefix   "ADOProperty-"
  143.         :constants-prefix     "ADOConstant-"
  144.        )
  145.      )
  146.      ((setq ado-p
  147.        (findfile
  148.          (if (getenv "systemdrive")
  149.            (strcat
  150.        (getenv "systemdrive")
  151.        "\\program files\\common files\\system\\ado\\msado15.dll"
  152.            )
  153.            "c:\\program files\\common files\\system\\ado\\msado15.dll"
  154.          )
  155.        )
  156.       )
  157.       (vlax-import-type-library
  158.         :tlb-filename     ado-p
  159.         :methods-prefix     "ADOMethod-"
  160.         :properties-prefix   "ADOProperty-"
  161.         :constants-prefix     "ADOConstant-"
  162.        )
  163.      )
  164.      (T
  165.       (alert
  166.         (strcat "Cannot find\n\""
  167.           (if ado-p
  168.       ado-p
  169.       "msado15.dll"
  170.           )
  171.           "\""
  172.         )
  173.       )
  174.      )
  175.    )
  176.   )
  177.   (T
  178.    (alert
  179.      (strcat "Cannot find\n\""
  180.        (if ado-p
  181.          ado-p
  182.          "msado15.dll"
  183.        )
  184.        "\""
  185.      )
  186.    )
  187.    (exit)
  188.   )
  189.       )
  190.     )
  191.   )
  192.   (defun $ado-sqlite-TRANSACTION$ (conn RecordSet begin?end)
  193.           ;事务法
  194.           ;($ado-sqlite-TRANSACTION$ conn RecordSet "BEGIN TRANSACTION");开启事务
  195.           ;($ado-sqlite-TRANSACTION$ conn RecordSet "END TRANSACTION");关闭事务并提交
  196.     (vl-catch-all-apply
  197.       'vlax-invoke-method
  198.       (list RecordSet "Open" begin?end conn nil  nil
  199.       ADOConstant-adCmdText)
  200.     )
  201.   )
  202.   (defun $ado-sqlite-do-sql$ (conn RecordSet sql)
  203.           ;执行sql语句
  204.     (vl-catch-all-apply
  205.       'vlax-invoke-method
  206.       (list RecordSet "Open" sql conn nil nil ADOConstant-adCmdText)
  207.     )
  208.   )
  209.   (defun $ado-sqlite-getfields$  (RecordSet   /
  210.          fieldcount   fielditem
  211.          fieldlist   fieldname
  212.          fieldnumber   fieldpropertieslist
  213.          fields     fieldsobject
  214.         )
  215.           ;字段
  216.     (setq FieldsObject
  217.      (vl-catch-all-apply
  218.        'vlax-get-property
  219.        (list RecordSet
  220.        "Fields"
  221.        )
  222.      )
  223.     )
  224.     (setq FieldCount
  225.      (vl-catch-all-apply
  226.        'vlax-get-property
  227.        (list FieldsObject "Count")
  228.      )
  229.     )
  230.     (setq FieldNumber -1)
  231.     (while
  232.       (> FieldCount
  233.    (setq FieldNumber (1+ FieldNumber))
  234.       )
  235.        (setq FieldItem (vlax-get-property
  236.        FieldsObject
  237.        "Item"
  238.        FieldNumber
  239.            )
  240.        )
  241.        (setq
  242.    FieldName (vlax-get-property
  243.          FieldItem
  244.          "Name"
  245.        )
  246.        )
  247.        (setq FieldList (cons FieldName FieldList))
  248.     )
  249.     (setq FieldList (reverse FieldList))
  250.     FieldList
  251.   )
  252.   (defun $ado-sqlite-getrows$ (RecordSet / bor eof)
  253.           ;获取数据
  254.     (setq bor (= :vlax-true
  255.      (vl-catch-all-apply
  256.        'vlax-get-property
  257.        (list RecordSet
  258.        "BOF"
  259.        )
  260.      )
  261.         )
  262.     )
  263.     (setq eof (= :vlax-true
  264.      (vl-catch-all-apply
  265.        'vlax-get-property
  266.        (list RecordSet
  267.        "EOF"
  268.        )
  269.      )
  270.         )
  271.     )
  272.     (if  (and bor eof)
  273.       ()
  274.       (progn
  275.   (setq safearray->list
  276.          (vl-catch-all-apply
  277.      'vlax-safearray->list
  278.      (list
  279.        (vl-catch-all-apply
  280.          'vlax-variant-value
  281.          (list
  282.            (vl-catch-all-apply
  283.        'vlax-invoke-method
  284.        (list
  285.          RecordSet
  286.          "GetRows"
  287.          ADOConstant-adGetRowsRest
  288.        )
  289.            )
  290.          )
  291.        )
  292.      )
  293.          )
  294.   )
  295.   (if (not (vl-catch-all-error-p safearray->list))
  296.     (apply
  297.       'mapcar
  298.       (cons
  299.         'list
  300.         (mapcar
  301.     (function (lambda (x)
  302.           (mapcar
  303.             (function  (lambda  (Item)
  304.             (vl-catch-all-apply
  305.               'vlax-variant-value
  306.               (list Item)
  307.             )
  308.           )
  309.             )
  310.             x
  311.           )
  312.         )
  313.     )
  314.     safearray->list
  315.         )
  316.       )
  317.     )
  318.   )
  319.       )
  320.     )
  321.   )
  322.   (defun $ADO-sqlite-Error$ (conn      VLErrorObject
  323.            /        ErrorsObject
  324.            ErrorObject    ErrorCount
  325.            ErrorNumber    ErrorList
  326.            ErrorValue      ReturnList
  327.           )
  328.           ;错误信息收集
  329.     (IF  VLErrorObject
  330.       (setq
  331.   ReturnList
  332.    (list
  333.      (list (cons "Visual LISP message"
  334.            (vl-catch-all-error-message VLErrorObject)
  335.      )
  336.      )
  337.    )
  338.       )
  339.     )
  340.     (setq ErrorObject
  341.      (vl-catch-all-apply
  342.        'vlax-create-object
  343.        (LIST "ADODB.Error")
  344.      )
  345.     )
  346.     (setq ErrorsObject
  347.      (vl-catch-all-apply
  348.        'vlax-get-property
  349.        (LIST conn "Errors")
  350.      )
  351.     )
  352.     (setq ErrorCount
  353.      (vl-catch-all-apply
  354.        'vlax-get-property
  355.        (LIST ErrorsObject "Count")
  356.      )
  357.     )
  358.     (setq ErrorNumber -1)
  359.     (while (AND  (NOT (vl-catch-all-error-p ErrorCount))
  360.     (< (setq ErrorNumber (1+ ErrorNumber)) ErrorCount)
  361.      )
  362.       (setq
  363.   ErrorObject
  364.    (vlax-get-property ErrorsObject "Item" ErrorNumber)
  365.   ErrorList nil
  366.       )
  367.       (foreach ErrorProperty '("Description"  "HelpContext"
  368.              "HelpFile"  "NativeError"
  369.              "Number"    "SQLState"
  370.              "Source"
  371.             )
  372.   (if (numberp (setq ErrorValue
  373.           (vlax-get-property ErrorObject ErrorProperty)
  374.          )
  375.       )
  376.     (setq ErrorValue (itoa ErrorValue))
  377.   )
  378.   (setq
  379.     ErrorList (cons (cons ErrorProperty ErrorValue) ErrorList)
  380.   )
  381.       )
  382.       (setq ReturnList (cons (reverse ErrorList) ReturnList))
  383.     )
  384.     (reverse ReturnList)
  385.   )
  386. )

评分

参与人数 2D豆 +6 收起 理由
HLCAD + 3 很给力!经验;技术要点;资料分享奖!
huangpc27 + 3 很给力!经验;技术要点;资料分享奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
发表于 4 天前 | 显示全部楼层
感谢共享!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

发表于 4 天前 | 显示全部楼层
这个怎么用啊
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2090个

财富等级: 金玉满堂

发表于 3 天前 | 显示全部楼层
做个对论坛有益的人。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2021-9-18 09:42 , Processed in 0.640927 second(s), 38 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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