;;;生成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