LISP通过ADO方法连接数据库

dcl1214 · 发表于 2021-9-13 22:51:28

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

您需要登录才可以下载或查看，没有账号？立即注册

×

(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)
)
)

(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) 
  ) 
)

guosheyang2 · 发表于 2021-9-14 17:42:23

感谢共享！

mercio · 发表于 2021-9-14 19:19:35

这个怎么用啊

yuren008 · 发表于 2021-9-15 15:30:44

做个对论坛有益的人。

hh_lj007 · 发表于 2021-9-18 11:43:51

感谢分享源码！

qqqincccken · 发表于 2021-9-22 01:02:40

謝謝提供收藏學習了

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

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

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

评分