设为首页收藏本站

中国膜结构网

 找回密码
 立即注册
膜结构车棚
汇聚新材料膜结构资质膜结构车棚国产膜材 膜结构网
查看: 5|回复: 0

LISP通过ADO方法连接数据库

[复制链接]
  • TA的每日心情
    开心
    2021-9-24 17:55
  • 签到天数: 17 天

    [LV.4]偶尔看看III

    发表于 2021-9-15 05:09 | 显示全部楼层 |阅读模式
    (progn
    ;|
    ($ado-sqlite-import$)
    (setq db-path ($db-path$))    ;数据库地址
    (setq con-str ($ConnectString$ db-path)) ;连接字串
    (mapcar  'set
      (list 'conn 'RecordSet)
      ($ado-sqlite-open$ con-str "" "")
    )          ;开启对象
    ($ado-sqlite-do-sql$ conn RecordSet "select * from fj") ;执行sql
    (setq fields ($ado-sqlite-getfields$ RecordSet))
    (setq rows ($ado-sqlite-getrows$ RecordSet))
    (setq data(cons fields rows))
    ($ado-sqlite-close$ RecordSet)    ;关闭对象
    ($ado-sqlite-close$ conn)    ;关闭对象
    ($ado-sqlite-release$ RecordSet)  ;释放对象
    ($ado-sqlite-release$ conn)    ;释放对象|;
      (defun $ConnectString$ (db-path)
              ;连接字串
        (strcat
          "Driver={SQLite3 ODBC Driver};Database="
          db-path
        )
      )

      (defun $ado-sqlite-open$ (ConnectString UserName Password)
              ;打开数据库
        (setq conn (vl-catch-all-apply
         'vlax-create-object
         (list "Adodb.Connection")
             )
        )
        (setq rs (vl-catch-all-apply
             'vlax-create-object
             (list "ADODB.RecordSet")
           )
        )
        (if  (not (vl-catch-all-error-p conn))
          (setq obj  (vl-catch-all-apply
          'vlax-invoke-method
          (list
            conn       "Open"
            ConnectString     UserName
            Password
            ADOConstant-adConnectUnspecified
           )
        )
          )
        )
        (if  (not (vl-catch-all-error-p obj))
          (list conn rs)
        )
      )
      (defun $ado-sqlite-close$ (conn?RecordSet)
              ;关闭
        (vl-catch-all-apply
          'vlax-invoke-method
          (list conn?RecordSet "Close")
        )
      )
      (defun $ado-sqlite-release$ (conn?RecordSet)
              ;释放
        (vl-catch-all-apply
          'vlax-release-object
          (list conn?RecordSet)
        )
      )
      (defun $ado-sqlite-import$ (/ ado-p)
              ;引入ado
        (if  (null ADOMethod-Append)
          (cond
      ((and (setq ado-p
             (vl-registry-read
               "HKEY_CLASSES_ROOT\\ADODB.Command\\CLSID"
             )
            )
            (setq ado-p
             (vl-registry-read
               (strcat "HKEY_CLASSES_ROOT\\CLSID\\"
                 ado-p
                 "\\InProcServer32"
               )
             )
            )
            (progn
        (if (listp ado-p)
          (setq ado-p (cdr ado-p))
        )
        (findfile ado-p)
            )
       )
       (vlax-import-type-library
         :tlb-filename  ado-p
         :methods-prefix  "ADOMethod-"
         :properties-prefix  "ADOProperty-"
         :constants-prefix  "ADOConstant-"
        )
      )
      ((setq ado-p
        (findfile
          (if (getenv "systemdrive")
            (strcat
              (getenv "systemdrive")
              "\\program files\\common files\\system\\ado\\msado15.dll"
            )
            "c:\\program files\\common files\\system\\ado\\msado15.dll"
          )
        )
       )
       (vlax-import-type-library
         :tlb-filename  ado-p
         :methods-prefix  "ADOMethod-"
         :properties-prefix  "ADOProperty-"
         :constants-prefix  "ADOConstant-"
        )
      )
      (if
       (null ADOMethod-Append)
       (cond
         ((and (setq ado-p
          (vl-registry-read
            "HKEY_CLASSES_ROOT\\ADODB.Command\\CLSID"
          )
         )
         (setq ado-p
          (vl-registry-read
            (strcat "HKEY_CLASSES_ROOT\\CLSID\\"
              ado-p
              "\\InProcServer32"
            )
          )
         )
         (progn
           (if (listp ado-p)
             (setq ado-p (cdr ado-p))
           )
           (findfile ado-p)
         )
          )
          (vlax-import-type-library
            :tlb-filename     ado-p
            :methods-prefix     "ADOMethod-"
            :properties-prefix   "ADOProperty-"
            :constants-prefix     "ADOConstant-"
           )
         )
         ((setq ado-p
           (findfile
             (if (getenv "systemdrive")
               (strcat
           (getenv "systemdrive")
           "\\program files\\common files\\system\\ado\\msado15.dll"
               )
               "c:\\program files\\common files\\system\\ado\\msado15.dll"
             )
           )
          )
          (vlax-import-type-library
            :tlb-filename     ado-p
            :methods-prefix     "ADOMethod-"
            :properties-prefix   "ADOProperty-"
            :constants-prefix     "ADOConstant-"
           )
         )
         (T
          (alert
            (strcat "Cannot find\n\""
              (if ado-p
          ado-p
          "msado15.dll"
              )
              "\""
            )
          )
         )
       )
      )
      (T
       (alert
         (strcat "Cannot find\n\""
           (if ado-p
             ado-p
             "msado15.dll"
           )
           "\""
         )
       )
       (exit)
      )
          )
        )
      )
      (defun $ado-sqlite-TRANSACTION$ (conn RecordSet begin?end)
              ;事务法
              ;($ado-sqlite-TRANSACTION$ conn RecordSet "BEGIN TRANSACTION");开启事务
              ;($ado-sqlite-TRANSACTION$ conn RecordSet "END TRANSACTION");关闭事务并提交
        (vl-catch-all-apply
          'vlax-invoke-method
          (list RecordSet "Open" begin?end conn nil  nil
          ADOConstant-adCmdText)
        )
      )
      (defun $ado-sqlite-do-sql$ (conn RecordSet sql)
              ;执行sql语句
        (vl-catch-all-apply
          'vlax-invoke-method
          (list RecordSet "Open" sql conn nil nil ADOConstant-adCmdText)
        )
      )
      (defun $ado-sqlite-getfields$  (RecordSet   /
             fieldcount   fielditem
             fieldlist   fieldname
             fieldnumber   fieldpropertieslist
             fields     fieldsobject
            )
              ;字段
        (setq FieldsObject
         (vl-catch-all-apply
           'vlax-get-property
           (list RecordSet
           "Fields"
           )
         )
        )
        (setq FieldCount
         (vl-catch-all-apply
           'vlax-get-property
           (list FieldsObject "Count")
         )
        )
        (setq FieldNumber -1)
        (while
          (> FieldCount
       (setq FieldNumber (1+ FieldNumber))
          )
           (setq FieldItem (vlax-get-property
           FieldsObject
           "Item"
           FieldNumber
               )
           )
           (setq
       FieldName (vlax-get-property
             FieldItem
             "Name"
           )
           )
           (setq FieldList (cons FieldName FieldList))
        )
        (setq FieldList (reverse FieldList))
        FieldList
      )
      (defun $ado-sqlite-getrows$ (RecordSet / bor eof)
              ;获取数据
        (setq bor (= :vlax-true
         (vl-catch-all-apply
           'vlax-get-property
           (list RecordSet
           "BOF"
           )
         )
            )
        )
        (setq eof (= :vlax-true
         (vl-catch-all-apply
           'vlax-get-property
           (list RecordSet
           "EOF"
           )
         )
            )
        )
        (if  (and bor eof)
          ()
          (progn
      (setq safearray->list
             (vl-catch-all-apply
         'vlax-safearray->list
         (list
           (vl-catch-all-apply
             'vlax-variant-value
             (list
               (vl-catch-all-apply
           'vlax-invoke-method
           (list
             RecordSet
             "GetRows"
             ADOConstant-adGetRowsRest
           )
               )
             )
           )
         )
             )
      )
      (if (not (vl-catch-all-error-p safearray->list))
        (apply
          'mapcar
          (cons
            'list
            (mapcar
        (function (lambda (x)
              (mapcar
                (function  (lambda  (Item)
                (vl-catch-all-apply
                  'vlax-variant-value
                  (list Item)
                )
              )
                )
                x
              )
            )
        )
        safearray->list
            )
          )
        )
      )
          )
        )
      )
      (defun $ADO-sqlite-Error$ (conn      VLErrorObject
               /        ErrorsObject
               ErrorObject    ErrorCount
               ErrorNumber    ErrorList
               ErrorValue      ReturnList
              )
              ;错误信息收集
        (IF  VLErrorObject
          (setq
      ReturnList
       (list
         (list (cons "Visual LISP message"
               (vl-catch-all-error-message VLErrorObject)
         )
         )
       )
          )
        )
        (setq ErrorObject
         (vl-catch-all-apply
           'vlax-create-object
           (LIST "ADODB.Error")
         )
        )
        (setq ErrorsObject
         (vl-catch-all-apply
           'vlax-get-property
           (LIST conn "Errors")
         )
        )
        (setq ErrorCount
         (vl-catch-all-apply
           'vlax-get-property
           (LIST ErrorsObject "Count")
         )
        )
        (setq ErrorNumber -1)
        (while (AND  (NOT (vl-catch-all-error-p ErrorCount))
        (< (setq ErrorNumber (1+ ErrorNumber)) ErrorCount)
         )
          (setq
      ErrorObject
       (vlax-get-property ErrorsObject "Item" ErrorNumber)
      ErrorList nil
          )
          (foreach ErrorProperty '("Description"  "HelpContext"
                 "HelpFile"  "NativeError"
                 "Number"    "SQLState"
                 "Source"
                )
      (if (numberp (setq ErrorValue
              (vlax-get-property ErrorObject ErrorProperty)
             )
          )
        (setq ErrorValue (itoa ErrorValue))
      )
      (setq
        ErrorList (cons (cons ErrorProperty ErrorValue) ErrorList)
      )
          )
          (setq ReturnList (cons (reverse ErrorList) ReturnList))
        )
        (reverse ReturnList)
      )
    )
    膜结构,张拉膜,膜结构车棚,膜结构停车棚,膜结构看台,膜结构煤棚,充气膜结构,膜结构价格
    回复

    使用道具 举报

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

    本版积分规则

    关闭

    推荐膜材品牌上一条 /6 下一条

    诺科膜结构
    遨都膜结构设计
    中国膜结构网
    中国空间膜结构

    QQ|手机版|中国膜结构论坛

    GMT+16, 2021-9-25 10:15 , Processed in 0.050889 second(s), 32 queries .

    Powered by Discuz! X3.4

    Copyright © 2001-2021, Tencent Cloud.

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