[转帖]在Visual LISP中使用Microsoft ActiveX Data Objects (ADO)接口与MS-Access和

夏夜星空

在Visual LISP中使用Microsoft ActiveX Data Objects (ADO)接口与MS-Access和
SQL Server相连接的例子。

通过类型库初始化ADO接口方法：

(defun DbInitADO ( / ADO_DLLPath)
  (if (null adom-Append)
    (progn

      ;; 尽管你可以把绝对路径输入到这里，但利用系统查找到的系统
      ;; 文件夹将会更加合理，可以避免不必要的错误。

      (setq ADO_DLLPath
        (strcat (getenv "systemdrive")
        "\\Program Files\\Common Files\\System\\Ado\\")
      )

      ;; 如果查找到类型库 ...

      (if (findfile (strcat ADO_DLLPath "msado15.dll"))

        ;; 将其输入

        (vlax-Import-Type-Library
          :tlb-filename   (strcat ADO_DLLPath "msado15.dll")
          :methods-prefix    "adom-"
          :properties-prefix "adop-"
          :constants-prefix  "adok-"
        )
        ;; 找不到时，则通知操作者
        (alert (strcat "不能找到以下文件\n" ADO_DLLPath "msado15.dll"))
      )
    )
  )
)


生成MS-Access 或 MS-SQL Server 数据库的连接字符串  

;;;******************************************************************
;;; 使用ODBC(不需要DSN)连接MS-Access数据库
;;; 示例： (DbConnect_MSAccess1 "d:/dbfiles/products.mdb")
;;;******************************************************************

(defun DbConnect_MSAccess1 (dbFile)
  (strcat
    "Provider=MSDASQL;"
    "Driver={Microsoft Access Driver (*.mdb)};"
    "DBQ=" dbFile
  )
)

;;;******************************************************************
;;; 使用JET 3.51连接MS-Access数据库
;;; 示例： (DbConnect_MSAccess2 "d:/dbfiles/products.mdb")
;;;******************************************************************

(defun DbConnect_MSAccess2 (dbFile)
  (strcat
    "Provider=Microsoft.Jet.OLEDB.3.51;"
    "Data Source=" dbFile
  )
)

;;;******************************************************************
;;; 使用ODBC(不需要DSN)连接MS-SQL数据库
;;; 示例： (DbConnect_MSSQL1 "SQLSERVER1" "products" "sa" "")
;;;******************************************************************

(defun DbConnect_MSSQL1 (dbServer dbName dbUser dbPassword)
  (strcat
    "Provider=SQLOLEDB;"
    "Driver={SQL Server};"
    "Server=" dbServer ";"
    "Database=" dbName ";"
    "UID=" dbUser ";"
    "PWD=" dbPassword
  )
)

;;;******************************************************************
;;; 使用ODBC连接MS-SQL数据库w/o
;;; Ex. (DbConnect_MSSQL2 "SQLSERVER2" "pr_catalog1" "sa" "")
;;;******************************************************************

(defun DbConnect_MSSQL2 (dbServer dbCatalog dbUser dbPassword)
  (strcat
    "Provider=SQLOLEDB;"
    "Data Source=" dbServer ";"
    "Initial Catalog=" dbCatalog ";"
    "User ID=" dbUser ";"
    "Password=" dbPassword
  )
)


生成适合不同情况的SQL字符串
(colName和Value可以为'nil或有值。如果Value为REAL、INT或STR，它可以计算到适
当的值中来取得正确的查询语法

(defun DbSQLCommand (tblName colName Value)
  (cond
    ( (and colName value (= (type value) 'STR))
      (strcat "SELECT * FROM " tblName " WHERE " colName " = '" Value "'")
    )
    ( (and colName value (= (type value) 'INT))
      (strcat "SELECT * FROM " tblName " WHERE " colName " = " (itoa
Value) )
    )
    ( (and colName value (= (type value) 'REAL))
      (strcat "SELECT * FROM " tblName " WHERE " colName " = " (itoa (fix
Value)) )
    )
    ( T (strcat "SELECT * FROM " tblName ) )
  ); cond
)


从内存中释放VLA对象

(defun MxRelease (xObject)
  (if (not (vlax-object-release-p xObject))
    (vlax-Release-Object xObject)
  )
)

关闭ADO Connection 对象并将内存释放出来  

(defun DbCloseConnection (dbConnObject)
  (vlax-Invoke-Method dbConnObject "Close")
  (MxRelease dbConnObject)
)


关闭ADO RecordSet对象并将内存释放出来

(defun DbCloseRecordset (rsObject)
  (vlax-Invoke-Method rsObject "Close")
  (MxRelease rsObject)
)


布尔测试RecordSet 是否为 Closed (T 或 nil)

(defun DbRsIsClosed (rsObject)
  (= adok-adStateClosed (vlax-Get-Property rsObject "State"))
)


返回一个ADO RecordSet对象中的记录数

(defun DbRsCount (rsObject)
  (vlax-Get-Property rsObject "RecordCount")
)


返回Field对象中给定字段数的字段名称

(defun DbGetFields (fObject fCount / FieldNumber)
  (setq FieldNumber -1)

  (while (> fCount (setq FieldNumber (1+ FieldNumber)))
    (setq FieldList
      (cons
        (vlax-Get-Property
          (DbRsFieldItem FieldsObject FieldNumber) "Name"
        )
        FieldList
      )
    ); setq
  ); end while
); defun


从RecordSet对象返回ADO Field对象

(defun DbRsFields (rsObject)
  (vlax-Get-Property rsObject "Fields")
)


返回给定Field对象的字段数量

(defun DbRsFieldCount (fObject)
  (vlax-Get-Property fObject "Count")
)


获取Field对象的字段名(项)

(defun DbRsFieldItem (fObject fNumber)
  (vlax-Get-Property fObject "Item" fNumber)
)


返回RecordSet对象的RowSet对象

(defun DbRsGetRows (rsObject)
  (vlax-Invoke-Method rsObject "GetRows" adok-adGetRowsRest)
)


应用一个ADO光标类型到给定的RecordSet对象

(defun DbRsCursorType (rsObject curType)
  (cond
    ( (= (strcase curType) "KEYSET")
      (vlax-Put-Property rsObject "CursorType" adok-adOpenKeyset)
    )
    ( (= (strcase curType) "DYNAMIC")
      (vlax-Put-Property rsObject "CursorType" adok-adOpenDynamic)
    )
  )
)


应用一个ADO LOCK(锁定)类型到给定的RecordSet对象

(defun DbRsLockType (rsObject lockType)
  (cond
    ( (= (strcase lockType) "OPTIMISTIC")
      (vlax-Put-Property rsObject "LockType" adok-adLockOptimistic)
    )
    ( (= (strcase lockType) "BATCHOPTIMISTIC")
      (vlax-Put-Property rsObject "LockType" adok-adLockBatchOptimistic)
    )
    ( (= (strcase lockType) "READONLY")
      (vlax-Put-Property rsObject "LockType" adok-adLockReadOnly)
    )
  )
)


创建并返回ADO Connection对象

(defun DbConnection ()
  (vlax-Create-Object "ADODB.Connection")
)


创建并返回ADO RecordSet对象

(defun DbRecordSet ()
  (vlax-Create-Object "ADODB.RecordSet")
)


将所有出错收集到一个点对形式("name" . "value")的列表中的函数  

(defun ErrorProcessor
  (VLErrorObject ConnectionObject / ErrorsObject
    ErrorObject ErrorCount ErrorNumber ErrorList
    ErrorValue
  )

  ;; 每一步获取Visual LISP的出错信息

  (setq ReturnList
        (list
          (list
            (cons "Visual LISP message"
            (vl-Catch-All-Error-Message VLErrorObject)
          )
        )
      )
      ;; 获取ADO出错对象及数量

        ErrorObject  (vlax-Create-object "ADODB.Error")
        ErrorsObject  (vlax-Get-Property ConnectionObject "Errors")
        ErrorCount   (vlax-Get-Property ErrorsObject "Count")
        ErrorNumber -1
  )

  ;; 循环所有ADO错误 ...
  (while (< (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))
    ); end foreach

    ;; 添加当前出错列表到返回值中
    (setq ReturnList (cons (reverse ErrorList) ReturnList))
  ); end while

  ;; 将返回值设置为正确的顺序
  (reverse ReturnList)

); defun


显示由ErrorProcessor函数生成的出错列表的函数。该函数与ErrorProcessor函数分开是
为了ErrorProcessor函数可以在DCL对话框显示时被调用，然后ErrorPrinter可以在对话
框结束后被调用。

(defun ErrorPrinter (ErrorsList)
  (foreach ErrorList ErrorsList
    (prompt "\n")
    (foreach ErrorItem ErrorList
      (prompt (strcat (car ErrorItem) "\t\t" (cdr ErrorItem) "\n") )
    )
  )
  (prin1)
)


以下为使用ADO的完整例子：

;;;******************************************************************
;;; 从Access数据库文件(dbFile)的表(tblName)中清理掉列(colName)值为给定的
;;; (value)值的表记录
;;;******************************************************************

(defun DbTableDump
  (dbFile tblName colName value / SQLStatement ConnectString)

  (setq ConnectString (DbConnect_MSAccess1 dbFile)
        SQLStatement (DbSQLCommand tblName colName value)
  ); setq
  (DbQuery ConnectString SQLStatement)
); defun

;;;******************************************************************
;;;  ADO 示例程序
;;;******************************************************************
;;; Connects 使用了公用变量ConnectString所指定的连接字符串，而SQL语句为公用
;;; 变量SQLStatement。
;;;
;;; 返回值:
;;;
;;; 如果出现任何错误，则返回NIL。
;;;
;;; 如果SQL语句为"select ..."语句则可返回行、返回一个列表的列表。第一个子列表
;;; 为列名称的列表。如果返回值中包含有行数据，则随后的子列表包含了与第一子列表中
;;; 列名称顺序相同的子列表。
;;;
;;; 如果SQL语句为"delete ..."、"update ..."或"insert ..."则不能返回任何行，
;;; 它将返回T。作者想让它返回所操作的行号，但到目前为止还找不到方法。
;;;******************************************************************

(defun DbQuery
  (ConnectString SQLStatement
    / ConnectionObject RecordSetObject FieldsObject FieldNumber
      FieldCount FieldList RecordsAffected TempObject ReturnValue
  )

  ;; 创建ADO连接对象

  (setq ConnectionObject (DbConnection))

  ;; 试图打开连接，如果出错 ...

  (if (vl-Catch-All-Error-p
      (setq TempObject
        (vl-Catch-All-Apply
          'vlax-Invoke-Method

          ;; 如果在ConnectString中已经包含了"admin"用户ID和""密码，则这
          ;; 两个参数可以不需要。
  
          (list
            ConnectionObject
            "Open"
            ConnectString
            "admin" ""
            adok-adConnectUnspecified
          )
        ); vl-Catch-All-Apply
      ); setq
    ); vl-Catch-All-Error-p

    ;; 则显示出错信息

    (ErrorPrinter (ErrorProcessor TempObject ConnectionObject))

    ;; 打开连接开始处理 ...

    (progn

    ;; 创建ADO Recordset并设置光标和锁定类型

      (setq RecordSetObject (DbRecordSet))
      (DbRsCursorType RecordSetObject "keyset")
      (DbRsLockType RecordSetObject "optimistic")

      ;; 打开recordset如果出错 ...

      (if (vl-Catch-All-Error-p
          (setq TempObject
            (vl-Catch-All-Apply
              'vlax-Invoke-Method
              (list RecordSetObject "Open" SQLStatement
                ConnectionObject nil nil adok-adCmdText
              )
            )
          )
        )
        ;; 则显示出错信息
        (progn
          (ErrorPrinter (ErrorProcessor TempObject ConnectionObject))
        )

        ;; 没有出错。如果recordset被关闭 ...

        (if (DbRsIsClosed RecordSetObject)

          ;; 则SQL语句为"delete ..."或"insert ..."或"update ..."，
          ;; 因为它没返回任何行。这里最好能返回操作过的行号，但作者还不知道
          ;; 怎样写。现在只有把返回值设为T来表示已经处理了。

          (progn
            (setq ReturnValue T)

            ;; 同时关闭recordset，这时已完成。
            (MxRelease RecordSetObject)
          )

          ;; recordset打开，SQL 语句为"select ..."。

          (progn

            ;; 获取Fields集合，它包含选定列的名称和属性。

            (setq FieldsObject (DbRsFields RecordSetObject) ;; 将字段作为对象
                  FieldCount   (DbRsFieldCount FieldsObject) ;; 取得列的数量
                  FieldList    (DbGetFields FieldsObject FieldCount);; 取得列表中所有列的名称
                  ReturnValue (list (reverse FieldList))
            ); setq

            ;; 如果找到任何行 ...

            (if (< 0 (DbRsCount RecordSetObject))

              ;; 我们来处理最棘手的问题!创建最后结果的列表 ...

              (setq
                  ReturnValue

                  ;; 添加行列表到字段列表中。

                      (append (list (reverse FieldList))

                      ;; 使用了Douglas Wilson一流的列表转换代码
                      ;; 来创建行列表，因为GetRows返回的项为列顺序

                        (apply 'mapcar
                          (cons
                            'list

                              ;; 设置转换变体列表的列表到AutoLISP标准
                              ;; 的项目列表的列表。

                              (mapcar
                                '(lambda (InputList)
                                    (mapcar '(lambda (Item)
                                      (DBL_variant-value Item)
                                    )
                                    InputList
                                  )
                              )
                              ;; 取得行，将其从变体转换安全数组再到列表

                              (setq t2 (vlax-SafeArray->list
                                  (vlax-Variant-Value
                                    (DbRsGetRows RecordSetObject)
                                  )
                                )
                              ); setq
                              ); mapcar
                          ); cons
                        ); apply
                      ); append
                ); setq
            ); endif

            ;; 关闭recordset
            (DbCloseRecordset RecordSetObject)

          ); progn
        ); endif
      ); endif

      ;; 关闭connection
      (DbCloseConnection ConnectionObject)

    ); progn
  ); endif

  ;; 返回值
  ReturnValue

); defun

（转自明经通道http://www.mjtd.com，来源http://www.acadx.com/，译：郑立楷）