设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 80|回复: 0

[原创] Lisp调用ODBC发送Sql语句操作Sqlite数据库

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

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

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

x
本帖最后由 dcl1214 于 2020-1-12 22:09 编辑

ODBC网上大把的,大家自己下载即可,直接上代码
  1.   (defun $jz->db$ (sj / CARS dbjg0 dbjg sss)
  2.     (if        (and sj (SETQ CARS (CAR sj)) (cdr sj))
  3.       (mapcar
  4.         '(lambda (z)
  5.            (MAPCAR 'CONS CARS Z)
  6.          )
  7.         (cdr sj)
  8.       )
  9.     )
  10.   )
  11. (defun $jz->sql$ (tbname jz / sql-cdr sqls title sql-cdr-fd)
  12.   (if (and tbname jz)
  13.     (progn
  14.       (and (apply '= (mapcar 'length jz)) ;防止每一个表的数量不相等
  15.            (setq
  16.              jz
  17.               (mapcar
  18.                 (function (lambda (a)
  19.                             (mapcar (function (lambda (b)
  20.                                                 (if (not (= (type b) 'str))
  21.                                                   (vl-princ-to-string b)
  22.                                                   b
  23.                                                 )
  24.                                               )
  25.                                     )
  26.                                     a
  27.                             )
  28.                           )
  29.                 )
  30.                 jz
  31.               )
  32.            )                                ;防止不是字串型
  33.            (setq title (car jz))
  34.            (setq title (merge-str-by-bar title "`,`"))
  35.            (setq title (strcat "`" title "`"))
  36.            (setq title (strcat "(" title ")"))
  37.            (setq jz (cdr jz))
  38.            (setvar "modemacro" "转储Sql语句■■■■■■■■")
  39.            (setq sql-cdr
  40.                   (mapcar
  41.                     (function
  42.                       (lambda (a) (strcat "('" (merge-str-by-bar a "','") "')"))
  43.                     )
  44.                     jz
  45.                   )
  46.            )
  47.            (SETQ SQLS (CONS title sql-cdr))
  48.       )
  49.     )
  50.   )
  51.   sqls
  52. )
  53. (defun $ADO_ErrorProcessor$ (VLErrorObject    ConnectionObject
  54.                              /                      ErrorsObject
  55.                              ErrorObject      ErrorCount
  56.                              ErrorNumber      ErrorList
  57.                              ErrorValue              ReturnList
  58.                             )
  59.   ;; First get Visual LISP's error message
  60.   (setq
  61.     ReturnList
  62.      (list
  63.        (list (cons "Visual LISP message"
  64.                    (vl-catch-all-error-message VLErrorObject)
  65.              )
  66.        )
  67.      )
  68.   )
  69.   ;; Get the ADO errors object and quantity
  70.   (setq        ErrorObject
  71.          (vl-catch-all-apply
  72.            'vlax-create-object
  73.            (LIST "ADODB.Error")
  74.          )
  75.   )
  76.   (setq        ErrorsObject
  77.          (vl-catch-all-apply
  78.            'vlax-get-property
  79.            (LIST ConnectionObject "Errors")
  80.          )
  81.   )
  82.   (setq        ErrorCount
  83.          (vl-catch-all-apply
  84.            'vlax-get-property
  85.            (LIST ErrorsObject "Count")
  86.          )
  87.   )
  88.   (setq ErrorNumber -1)
  89.   ;; Loop over all the ADO errors ...
  90.   (while (AND (NOT (vl-catch-all-error-p ErrorCount))
  91.               (< (setq ErrorNumber (1+ ErrorNumber)) ErrorCount)
  92.          )
  93.     ;; Get the error object of the current error
  94.     (setq
  95.       ErrorObject (vlax-get-property ErrorsObject "Item" ErrorNumber)
  96.       ;; Clear the list of items for this error
  97.       ErrorList          nil
  98.     )
  99.     ;; Loop over all possible error items of this error
  100.     (foreach ErrorProperty '("Description"    "HelpContext"
  101.                              "HelpFile"              "NativeError"
  102.                              "Number"              "SQLState"
  103.                              "Source"
  104.                             )
  105.       ;;  Get the value of the current item.  If it's a number ...
  106.       (if (numberp (setq ErrorValue
  107.                           (vlax-get-property ErrorObject ErrorProperty)
  108.                    )
  109.           )
  110.         ;; Convert it to a string for consistency
  111.         (setq ErrorValue (itoa ErrorValue))
  112.       )
  113.       ;; And store it
  114.       (setq ErrorList (cons (cons ErrorProperty ErrorValue) ErrorList))
  115.     )
  116.     ;; Add the list for the current error to the return value
  117.     (setq ReturnList (cons (reverse ErrorList) ReturnList))
  118.   )
  119.   ;; Set up the return value in the correct order
  120.   (reverse ReturnList)
  121. )
  122. (defun $DO-SQL-sqlite-ado$ (lst
  123.                                 /
  124.                                 $ADO_ConnectToDB$
  125.                                 adolisp_errorlist
  126.                                 adolisp_fieldspropertieslist
  127.                                 adolisp_lastsqlstatement
  128.                                 CommandObject
  129.                                 connectionobject
  130.                                 db-path
  131.                                 FieldCount
  132.                                 FieldItem
  133.                                 FieldList
  134.                                 FieldName
  135.                                 FieldNumber
  136.                                 FieldPropertiesList
  137.                                 FieldsObject
  138.                                 IsError                                
  139.                                 RecordsAffected
  140.                                 RecordSetObject
  141.                                 ReturnValue
  142.                                 sqlstatement
  143.                                 TempObject
  144.                                 $TRANSACTION$
  145.                                )
  146.   
  147.   (defun $ADO_ConnectToDB$ (ConnectString
  148.                             UserName
  149.                             Password
  150.                             /
  151.                             adolisp_errorlist
  152.                             adolisp_lastsqlstatement
  153.                             ConnectionObject
  154.                             ConnectionParsingPropertyObject
  155.                             ConnectionPropertiesObject
  156.                             FullUDLFileName
  157.                             IsUDL
  158.                             ReturnValue
  159.                             TempObject
  160.                            )
  161.     (setq ADOLISP_ErrorList nil)
  162.     (SETQ ADOLISP_LastSQLStatement nil)
  163.     (progn
  164.       (setq ConnectionObject
  165.              (vlax-create-object "ADODB.Connection")
  166.       )
  167.       (if (vl-catch-all-error-p
  168.             (setq TempObject
  169.                    (vl-catch-all-apply
  170.                      'vlax-invoke-method
  171.                      (list
  172.                        ConnectionObject
  173.                        "Open"
  174.                        ConnectString
  175.                        UserName
  176.                        Password
  177.                        ADOConstant-adConnectUnspecified
  178.                       )
  179.                    )
  180.             )
  181.           )
  182.         (progn
  183.           (setq        ADOLISP_ErrorList
  184.                  ($ADO_ErrorProcessor$ TempObject ConnectionObject)
  185.           )
  186.           (print "开启数据库失败")
  187.           (mapcar 'print ADOLISP_ErrorList)
  188.           (and ConnectionObject
  189.                (vlax-release-object ConnectionObject)
  190.           )
  191.         )
  192.         (setq ReturnValue ConnectionObject)
  193.       )
  194.     )
  195.     (if        ReturnValue
  196.       (progn
  197.         (if (not ADOLISP_DoNotForceJetODBCParsing)
  198.           (progn
  199.             (setq ConnectionPropertiesObject
  200.                    (vl-catch-all-apply
  201.                      'vlax-get-property
  202.                      (list ReturnValue
  203.                            "Properties"
  204.                      )
  205.                    )
  206.             )
  207.             (if        (not (vl-catch-all-error-p
  208.                        (setq ConnectionParsingPropertyObject
  209.                               (vl-catch-all-apply
  210.                                 'vlax-get-property
  211.                                 (list
  212.                                   ConnectionPropertiesObject
  213.                                   "ITEM"
  214.                                   "Jet OLEDB:ODBC Parsing"
  215.                                 )
  216.                               )
  217.                        )
  218.                      )
  219.                 )
  220.               (vl-catch-all-apply
  221.                 'vlax-put-property
  222.                 (list ConnectionParsingPropertyObject
  223.                       "VALUE"
  224.                       :vlax-true
  225.                 )
  226.               )
  227.             )
  228.           )
  229.         )
  230.         (if (= 'VLA-OBJECT (type ConnectionParsingPropertyObject))
  231.           (and ConnectionParsingPropertyObject
  232.                (vlax-release-object ConnectionParsingPropertyObject)
  233.           )
  234.         )
  235.         (if (= 'VLA-OBJECT (type ConnectionPropertiesObject))
  236.           (and ConnectionPropertiesObject
  237.                (vlax-release-object ConnectionPropertiesObject)
  238.           )
  239.         )
  240.       )
  241.     )
  242.     ReturnValue
  243.   )
  244.   (defun $TRANSACTION$ (ConnectionObject    RecordSetObject
  245.                         SQLStatement            /
  246.                         BEGIN_TRANSACTION   TempObject
  247.                         END_TRANSACTION
  248.                        )
  249.                                         ;事务法提交
  250.     (if        (and SQLStatement (= (type SQLStatement) 'list))
  251.       (progn
  252.         (setq BEGIN_TRANSACTION
  253.                (vl-catch-all-apply
  254.                  'vlax-invoke-method
  255.                  (list RecordSetObject            "Open"
  256.                        "BEGIN TRANSACTION"  ConnectionObject
  257.                        nil                    nil
  258.                        ADOConstant-adCmdText
  259.                       )
  260.                )
  261.         )
  262.         (if (not (vl-catch-all-error-p BEGIN_TRANSACTION))
  263.           (progn
  264.             (setq TempObject
  265.                    (mapcar (function (lambda (sql)
  266.                                        (vl-catch-all-apply
  267.                                          'vlax-invoke-method
  268.                                          (list
  269.                                            RecordSetObject
  270.                                            "Open"
  271.                                            sql
  272.                                            ConnectionObject
  273.                                            nil
  274.                                            nil
  275.                                            ADOConstant-adCmdText
  276.                                           )
  277.                                        )
  278.                                      )
  279.                            )
  280.                            SQLStatement
  281.                    )
  282.             )
  283.           )
  284.         )
  285.         (vl-catch-all-error-p
  286.           (setq        END_TRANSACTION
  287.                  (vl-catch-all-apply
  288.                    'vlax-invoke-method
  289.                    (list RecordSetObject     "Open"
  290.                          "END TRANSACTION"   ConnectionObject
  291.                          nil                     nil
  292.                          ADOConstant-adCmdText
  293.                         )
  294.                  )
  295.           )
  296.         )
  297.       )
  298.     )
  299.     TempObject
  300.   )
  301.   (if $jz->db$()(alert "缺少  $jz->db$  函数"))
  302.   (if (and lst
  303.            (setq db-path (cdr (assoc "数据库路径" lst)))
  304.            (vl-filename-extension db-path)
  305.            (findfile db-path)
  306.       )
  307.     (progn
  308.       (if (and db-path(setq        ConnectionObject
  309.                  ($ADO_ConnectToDB$
  310.                    (strcat "Driver={SQLite3 ODBC Driver}; Database=" db-path)
  311.                    ""
  312.                    ""
  313.                  )
  314.           ))
  315.         (progn
  316.           (if
  317.             (and lst
  318.                  (setq SQLStatement (cdr (assoc "SQL语句" lst)))
  319.                  (= (type SQLStatement) 'list) ;sql语句必须是list格式的
  320.             )
  321.              (progn
  322.                (IF (vl-some
  323.                      (function
  324.                        (lambda (sql)
  325.                          (AND sql
  326.                               (WCMATCH (strcase sql) "[,*IS NOT NULL,]")
  327.                          )
  328.                        )
  329.                      )
  330.                      SQLStatement
  331.                    )
  332.                  (PRINT
  333.                    "SQL statement has “IS NOT NULL”, Data volume large Of time Hou Probably cause Access conflict"
  334.                  )
  335.                )
  336.                (setq ADOLISP_ErrorList nil)
  337.                (setq ADOLISP_LastSQLStatement SQLStatement)
  338.                (setq ADOLISP_FieldsPropertiesList nil)
  339.                (setq RecordSetObject
  340.                       (vl-catch-all-apply
  341.                         'vlax-create-object
  342.                         (list "ADODB.RecordSet")
  343.                       )
  344.                )
  345.                (if (not (vl-catch-all-error-p RecordSetObject))
  346.                  (progn
  347.                    (vl-catch-all-apply
  348.                      'vlax-put-property
  349.                      (list RecordSetObject
  350.                            "cursorType"
  351.                            3
  352.                      )
  353.                    )
  354.                    (vl-catch-all-apply
  355.                      'vlax-put-property
  356.                      (list RecordSetObject
  357.                            "LockType"
  358.                            3
  359.                      )
  360.                    )
  361.                    (if (= (cdr (assoc "启用事务" lst)) "是")
  362.                                         ;只有:DML、INSERT、UPDATE、DELETE支持事务提交,上级调用的时候注意一下
  363.                      (progn
  364.                        (if (vl-some
  365.                              (function
  366.                                (lambda (a) (vl-catch-all-error-p a))
  367.                              )
  368.                              (setq TempObjects
  369.                                     ($TRANSACTION$
  370.                                       ConnectionObject
  371.                                       RecordSetObject
  372.                                       SQLStatement
  373.                                     )
  374.                              )
  375.                            )
  376.                          (progn
  377.                            (setq ADOLISP_ErrorList
  378.                                   (mapcar (function (lambda (a)
  379.                                                       ($ADO_ErrorProcessor$
  380.                                                         a
  381.                                                         ConnectionObject
  382.                                                       )
  383.                                                     )
  384.                                           )
  385.                                           TempObjects
  386.                                   )
  387.                            )
  388.                            (setq IsError T)
  389.                            (setq ReturnValue nil)
  390.                            (and        RecordSetObject
  391.                                 (vlax-release-object RecordSetObject)
  392.                            )
  393.                          )
  394.                          (progn        (setq RecordsAffected T)
  395.                                 (setq ReturnValue t)
  396.                          )
  397.                        )
  398.                      )
  399.                                         ;事务法提交sql
  400.                      (PROGN
  401.                        (SETQ TempObjectS
  402.                               (MAPCAR (FUNCTION
  403.                                         (LAMBDA        (SQL)
  404.                                           (vl-catch-all-apply
  405.                                             'vlax-invoke-method
  406.                                             (list
  407.                                               RecordSetObject
  408.                                               "Open"
  409.                                               SQL
  410.                                               ConnectionObject
  411.                                               nil
  412.                                               nil
  413.                                               ADOConstant-adCmdText
  414.                                              )
  415.                                           )
  416.                                         )
  417.                                       )
  418.                                       SQLStatement
  419.                               )
  420.                        )

  421.                        (if (vl-some
  422.                              (function
  423.                                (lambda (a) (vl-catch-all-error-p a))
  424.                              )
  425.                              TempObjectS
  426.                            )
  427.                          (progn
  428.                            (setq ADOLISP_ErrorList
  429.                                   (mapcar (function (lambda (a)
  430.                                                       ($ADO_ErrorProcessor$
  431.                                                         a
  432.                                                         ConnectionObject
  433.                                                       )
  434.                                                     )
  435.                                           )
  436.                                           TempObjects
  437.                                   )
  438.                            )
  439.                            (setq IsError T)
  440.                            (and        RecordSetObject
  441.                                 (vlax-release-object RecordSetObject)
  442.                            )
  443.                          )
  444.                          (setq RecordsAffected T)
  445.                        )
  446.                      )
  447.                    )
  448.                    (if (= (cdr (assoc "启用事务" lst)) "是")
  449.                      ()                        ;启用事务法不管返回值了
  450.                      (if (not IsError)
  451.                        (if (= (vl-catch-all-apply
  452.                                 'vlax-get-property
  453.                                 (list RecordsetObject "State")
  454.                               )
  455.                               0                ;如果连接已经关闭
  456.                            )
  457.                          (progn
  458.                            (setq ReturnValue RecordsAffected)
  459.                            (and        RecordSetObject
  460.                                 (vlax-release-object RecordSetObject)
  461.                            )
  462.                          )
  463.                          (progn
  464.                            (setq FieldsObject
  465.                                   (vl-catch-all-apply
  466.                                     'vlax-get-property
  467.                                     (list RecordSetObject
  468.                                           "Fields"
  469.                                     )
  470.                                   )
  471.                            )
  472.                            (setq FieldCount
  473.                                   (vl-catch-all-apply
  474.                                     'vlax-get-property
  475.                                     (list FieldsObject "Count")
  476.                                   )
  477.                            )
  478.                            (setq FieldNumber -1)
  479.                            (while
  480.                              (>        FieldCount
  481.                                 (setq FieldNumber (1+ FieldNumber))
  482.                              )
  483.                               (setq FieldItem (vlax-get-property
  484.                                                 FieldsObject
  485.                                                 "Item"
  486.                                                 FieldNumber
  487.                                               )
  488.                               )
  489.                               (setq
  490.                                 FieldName (vlax-get-property
  491.                                             FieldItem
  492.                                             "Name"
  493.                                           )
  494.                               )
  495.                               (setq FieldList (cons FieldName FieldList))
  496.                               (setq FieldPropertiesList nil)
  497.                               (foreach FieldProperty '("Type"
  498.                                                        "Precision"
  499.                                                        "NumericScale"
  500.                                                        "DefinedSize"
  501.                                                        "Attributes")
  502.                                 (setq FieldPropertiesList
  503.                                        (cons (cons FieldProperty
  504.                                                    (vlax-get-property
  505.                                                      FieldItem
  506.                                                      FieldProperty
  507.                                                    )
  508.                                              )
  509.                                              FieldPropertiesList
  510.                                        )
  511.                                 )
  512.                               )
  513.                               (setq ADOLISP_FieldsPropertiesList
  514.                                      (cons
  515.                                        (cons FieldName
  516.                                              FieldPropertiesList
  517.                                        )
  518.                                        ADOLISP_FieldsPropertiesList
  519.                                      )
  520.                               )
  521.                            )
  522.                            (setq ADOLISP_FieldsPropertiesList
  523.                                   (reverse
  524.                                     ADOLISP_FieldsPropertiesList
  525.                                   )
  526.                            )
  527.                            (setq ReturnValue (list (reverse FieldList)))
  528.                            (if
  529.                              (not
  530.                                (and (= :vlax-true
  531.                                        (vl-catch-all-apply
  532.                                          'vlax-get-property
  533.                                          (list RecordSetObject
  534.                                                "BOF"
  535.                                          )
  536.                                        )
  537.                                     )
  538.                                     (= :vlax-true
  539.                                        (vl-catch-all-apply
  540.                                          'vlax-get-property
  541.                                          (list RecordSetObject
  542.                                                "EOF"
  543.                                          )
  544.                                        )
  545.                                     )
  546.                                )
  547.                              )
  548.                               (progn
  549.                                 (setq safearray->list
  550.                                        (vl-catch-all-apply
  551.                                          'vlax-safearray->list
  552.                                          (list
  553.                                            (vl-catch-all-apply
  554.                                              'vlax-variant-value
  555.                                              (list
  556.                                                (vl-catch-all-apply
  557.                                                  'vlax-invoke-method
  558.                                                  (list
  559.                                                    RecordSetObject
  560.                                                    "GetRows"
  561.                                                    ADOConstant-adGetRowsRest
  562.                                                  )
  563.                                                )
  564.                                              )
  565.                                            )
  566.                                          )
  567.                                        )
  568.                                 )
  569.                                 (if
  570.                                   (not
  571.                                     (vl-catch-all-error-p safearray->list)
  572.                                   )
  573.                                    (setq
  574.                                      ReturnValue
  575.                                       (append
  576.                                         (list (reverse FieldList))
  577.                                         (apply
  578.                                           'mapcar
  579.                                           (cons
  580.                                             'list
  581.                                             (mapcar
  582.                                               '(lambda (InputList)
  583.                                                  (mapcar
  584.                                                    '(lambda (Item)
  585.                                                       (vl-catch-all-apply
  586.                                                         'vlax-variant-value
  587.                                                         (list Item)
  588.                                                       )
  589.                                                     )
  590.                                                    InputList
  591.                                                  )
  592.                                                )
  593.                                               safearray->list
  594.                                             )
  595.                                           )
  596.                                         )
  597.                                       )
  598.                                    )
  599.                                 )
  600.                               )
  601.                            )
  602.                            (vl-catch-all-apply
  603.                              'vlax-invoke-method
  604.                              (list RecordSetObject "Close")
  605.                            )
  606.                            (vl-catch-all-apply
  607.                              'vlax-release-object
  608.                              (list RecordSetObject)
  609.                            )
  610.                          )
  611.                        )
  612.                      )
  613.                    )
  614.                  )
  615.                  (progn (print "调用 ADODB.RecordSet 对象失败") nil)
  616.                )
  617.              )
  618.              (progn (print "未传入Sql语句") nil)
  619.           )
  620.         )
  621.         (progn (print "开启Ado组件失败") nil)
  622.       )
  623.       (cond ((AND LST
  624.                   ReturnValue
  625.                   (= (type ReturnValue) 'list)
  626.                   (assoc "返回数据格式" lst)
  627.                   (wcmatch (cdr (assoc "返回数据格式" lst)) "[,db,DB,]")
  628.              )
  629.              (setq ReturnValue ($jz->db$ ReturnValue))
  630.             )
  631.             ((AND LST
  632.                   ReturnValue
  633.                   (= (type ReturnValue) 'list)
  634.                   (assoc "返回数据格式" lst)
  635.                   (wcmatch (cdr (assoc "返回数据格式" lst)) "[,jz,JZ,]")
  636.              )
  637.              t                                ;矩阵模式不用处理
  638.             )
  639.             (t nil)
  640.       )
  641.     )
  642.     (progn (print "未传入db库路径或者是db库文件找不到") nil)
  643.   )
  644.   ReturnValue
  645. )




调用示例:
  1. ($DO-SQL-sqlite-ado$
  2.   (list
  3.     (cons "数据库路径" (findfile "zxcad.db"))
  4.     (cons "SQL语句"
  5.           (list "select * from 连接器 where `编码` = '282080-1'")
  6.     )
  7.     (cons "返回数据格式" "db")
  8.     (cons "启用事务" "否")
  9.   )
  10. )


论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

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

GMT+8, 2020-1-18 06:57 , Processed in 0.129376 second(s), 14 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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