- UID
- 3831
- 积分
- 0
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2002-4-14
- 最后登录
- 1970-1-1
|
发表于 2002-7-23 21:04:42
|
显示全部楼层
;;; A set of routines demonstrating how you can access a database
;;; from Visual LISP in AutoCAD 2000 using ActiveX Data Objects
;;; (ADO)
;;; Copyright (C) 1999 by The Fleming Group
;;; Permission to use, copy, modify, and distribute this software
;;; for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appears in all copies and
;;; that both that copyright notice and the limited warranty and
;;; restricted rights notice below appear in all supporting
;;; documentation.
;;; THE FLEMING GROUP PROVIDES THIS PROGRAM "AS IS" AND WITH ALL
;;; FAULTS. THE FLEMING GROUP SPECIFICALLY DISCLAIMS ANY IMPLIED
;;; WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.
;;; THE FLEMING GROUP DOES NOT WARRANT THAT THE OPERATION OF THE
;;; PROGRAM WILL BE UNINTERRUPTED OR ERROR FREE.
;;; ----------------------------------------------------------
;;; Set up some global variables
;;; Define a VB data type that Visual LISP forgot
(setq vlax-vbDecimal 14)
;; Connection string for connecting to any ODBC Data Source by
;; its ODBC name. Connection strings should not have any extra spaces in
;; them. The DSN is the name for the Data Source that is entered
;; in the ODBC manager.
(setq ConnectString "Provider=MSDASQL;DSN=DBL_TEST"
;; Connection string for connecting to an Access database using
;; an ODBC driver and the database file name. You do not have
;; to define an ODBC Data Source if you use this method. Note
;; that the driver name is the exact name listed in the ODBC
;; manager, in curly braces
ConnectString "Provider=MSDASQL;Driver={Microsoft Access Driver (*.mdb)};DBQ=C:\\dbl_test.mdb"
;; Connection string for connecting to an Access database using
;; the Jet driver and the database file name. The version of
;; the MDB file must be the same as the version of Access
;; installed in your system.
;;; ConnectString "Provider=Microsoft.Jet.OLEDB.3.51;Data Source=C:\\dbl_test.mdb"
;; Connection string for connecting to SQL Server using an ODBC
;; driver, You do not have to define an ODBC data source if you
;; use this method. Note that the driver name is the exact
;; name listed in the ODBC manager, in curly braces
;;; ConnectString "Provider=SQLOLEDB;Driver={SQL Server};Server=servername;Database=dbname;UID=userid;PWD=password"
;; Connection string for connecting to SQL Server without using
;; ODBC
;;; ConnectString "Provider=SQLOLEDB;Data Source=servername;Initial Catalog=dbname;User ID=userid;Password=password"
;; Standard place to find the ADO files
ADO_DLLPath "c:\\program files\\common files\\system\\ado\\"
;; The SQL statement we are going to execute (could be
;; "select ...", "insert ...", or anything).
SQLStatement "SELECT * FROM DESKS WHERE AUTOCAD_HANDLE = '2A'"
)
;;;(setq ConnectString "Provider=MSDASQL;Driver={Microsoft Access Driver (*.mdb)};DBQ=C:\\typetest.mdb"
;;; SQLStatement "SELECT * FROM TEST ORDER BY \"Text Field\" DESC"
;;;)
;; Load the ActiveX stuff for Visual LISP if it isn't already
;; loaded
(vl-load-com)
;; Import the ADO type library if it hasn't already been loaded.
(if (null adom-Append)
;; If we can find the library ...
(if (findfile (strcat ADO_DLLPath "msado15.dll"))
;; Import it
(vlax-import-type-library
:tlb-filename
(strcat ADO_DLLPath "msado15.dll")
:methods-prefix
"adom-"
:properties-prefix
"adop-"
:constants-prefix
"adok-"
)
;; Can't find the library, tell the user
(alert (strcat "Cannot find\n" ADO_DLLPath "msado15.dll"))
)
)
;;; A ADO demonstration program.
;;; Connects using the connection string specified in the global
;;; variable ConnectString and executes the SQL statement contained
;;; in the global variable SQLStatement.
;;; Return value:
;;; If anything fails, NIL.
;;; If the SQL statement is a "select ..." statement that
;;; could return rows, returns a list of lists. The first sub-list
;;; is a list of the column names. If any rows were returned,
;;; the subsequent sub-lists contain the returned rows in the same
;;; order as the column names in the first sub-list.
;;; If the SQL statement is a "delete ...", "update ...", or
;;; "insert ..." that cannot return any rows, returns T. I
;;; want to have it return the number of rows affected, but
;;; I haven't figured out how to do that.
(defun test (/ ConnectionObject RecordSetObject FieldsObject FieldNumber
FieldCount FieldList RecordsAffected TempObject ReturnValue
)
;; Create an ADO connection object
(setq ConnectionObject (vlax-create-object "ADODB.Connection"))
;; Try to open the connection. If there is an error ...
(if (vl-catch-all-error-p
(setq TempObject
(vl-catch-all-apply
'vlax-invoke-method
;; The "admin" userid and "" password may not be
;; needed if they are already contained in the
;; ConnectString.
(list ConnectionObject "Open" ConnectString "admin" ""
adok-adConnectUnspecified
)
)
)
)
;; Then print the error information
(ErrorPrinter (ErrorProcessor TempObject ConnectionObject))
;; Opening the connection worked ...
(progn
;; Create an ADO Recordset and set the cursor and lock types
(setq RecordSetObject (vlax-create-object "ADODB.RecordSet"))
(vlax-put-property
RecordSetObject
"cursorType"
adok-adOpenKeyset
)
(vlax-put-property
RecordSetObject
"LockType"
adok-adLockOptimistic
)
;; Open the recordset. If there is an error ...
(if (vl-catch-all-error-p
(setq TempObject
(vl-catch-all-apply
'vlax-invoke-method
(list RecordSetObject "Open" SQLStatement
ConnectionObject nil nil adok-adCmdText
)
)
)
)
;; Then print the error information
(progn
(ErrorPrinter (ErrorProcessor TempObject ConnectionObject))
)
;; There were no errors. If the recordset is closed ...
(if (= adok-adStateClosed
(vlax-get-property RecordsetObject "State")
)
;; Then the SQL statement was a "delete ..." or an
;; "insert ..." or an "update ..." which doesn't
;; return any rows. It would be nice to get the
;; number of affected rows, but I don't know how.
;; For now, just set our return value to T to
;; indicate that it worked.
(progn
(setq ReturnValue T)
;; And close the recordset; we're done.
(vlax-release-object RecordSetObject)
)
;; The recordset is open, the SQL statement
;; was a "select ...".
(progn
;; Get the Fields collection, which
;; contains the names and properties of the
;; selected columns
(setq FieldsObject (vlax-get-property
RecordSetObject
"Fields"
)
;; Get the number of columns
FieldCount (vlax-get-property FieldsObject "Count")
FieldNumber -1
)
;; Get the names of all the columns in a list
(while (> FieldCount (setq FieldNumber (1+ FieldNumber)))
(setq FieldList
(cons
(vlax-get-property
(vlax-get-property FieldsObject "Item" FieldNumber)
"Name"
)
FieldList
)
)
)
(setq ReturnValue (list (reverse FieldList)))
;; If there were any rows retrieved ...
(if
(< 0 (vlax-get-property RecordSetObject "RecordCount"))
;; We're about to get tricky, hang on! Create the
;; final results list ...
(setq
ReturnValue
;; By appending the list of rows to the list of
;; fields.
(append (list (reverse FieldList))
;; Uses Douglas Wilson's elegant
;; list-transposing code from
;; http://xarch.tu-graz.ac.at/autocad/lisp/
;; to create the list of rows, because
;; GetRows returns items in column order
(apply
'mapcar
(cons
'list
;; Set up to convert a list of lists
;; of variants to a list of lists of
;; items that AutoLISP understands
(mapcar
'(lambda (InputList)
(mapcar '(lambda (Item)
(DBL_variant-value Item)
)
InputList
)
)
;; Get the rows, converting them from
;; a variant to a safearray to a list
(setq t2 (vlax-safearray->list
(vlax-variant-value
(vlax-invoke-method
RecordSetObject
"GetRows"
adok-adGetRowsRest
)
)
)
)
)
)
)
)
)
)
;; Close the recordset
(vlax-invoke-method RecordSetObject "Close")
(vlax-release-object RecordSetObject)
)
)
)
;; Close the connection
(vlax-invoke-method ConnectionObject "Close")
(vlax-release-object ConnectionObject)
)
)
;; And return the results
ReturnValue
)
;;;------------------------------------------------------------
;;; Support functions
;;; A function to assemble all errors into a list of lists of
;;; dotted pairs of strings ("name" . "value")
(defun ErrorProcessor (VLErrorObject ConnectionObject / ErrorsObject
ErrorObject ErrorCount ErrorNumber ErrorList
ErrorValue
)
;; First get Visual LISP's error message
(setq ReturnList (list
(list (cons "Visual LISP message"
(vl-catch-all-error-message VLErrorObject)
)
)
)
;; Get the ADO errors object and quantity
ErrorObject (vlax-create-object "ADODB.Error")
ErrorsObject (vlax-get-property ConnectionObject "Errors")
ErrorCount (vlax-get-property ErrorsObject "Count")
ErrorNumber -1
)
;; Loop over all the ADO errors ...
(while (< (setq ErrorNumber (1+ ErrorNumber)) ErrorCount)
;; Get the egror object of the current error
(setq ErrorObject
(vlax-get-property ErrorsObject "Item" ErrorNumber)
;; Clear the list of items for this error
ErrorList nil
)
;; Loop over all possible error itmes of this error
(foreach ErrorProperty '("Description" "HelpContext" "HelpFile"
"NativeError" "Number" "SQLState" "Source"
)
;; Get the value of the curent item. If it's a number ...
(if (numberp (setq ErrorValue
(vlax-get-property ErrorObject ErrorProperty)
)
)
;; Convert it to a string for consistency
(setq ErrorValue (itoa ErrorValue))
)
;; And store it
(setq ErrorList (cons (cons ErrorProperty ErrorValue) ErrorList))
)
;; Add the list for the current error to the return value
(setq ReturnList (cons (reverse ErrorList) ReturnList))
)
;; Set up the return value in the correct order
(reverse ReturnList)
)
;;; A function to print the list of errors generated
;;; by the ErrorProcessor function. The functions
;;; are separate so ErrorProcessor can be called
;;; while a DCL dialog box is displayed and then
;;; ErrorPrinter can be called after the dialog
;;; box has been removed.
(defun ErrorPrinter (ErrorsList)
(foreach ErrorList ErrorsList
(prompt "\n")
(foreach ErrorItem ErrorList
(prompt (strcat (car ErrorItem) "\t\t" (cdr ErrorItem) "\n")
)
)
)
(prin1)
)
;;; A function to convert a variant to a value. Knows
;;; about more variant types than vlax-variant-value
(defun DBL_variant-value (VariantItem / VariantType)
(cond
;; If it's a Currency data type or a Decimal data type ...
((or (= vlax-vbCurrency
(setq VariantType (vlax-variant-type VariantItem))
)
;; Note that I defined vlax-vbDecimal
;; at the beginning of the file
(= vlax-vbDecimal VariantType)
)
;; Convert it to a double before getting its value
(vlax-variant-value
(vlax-variant-change-type VariantItem vlax-vbDouble)
)
)
;; If it's a date, time, or date/time variable type ...
((= vlax-vbDate VariantType)
;; Convert it to a string (assuming it's a Microsoft
;; Access type Julian date)
(1900BasedJulianToCalender (vlax-variant-value VariantItem))
)
;; If it's a boolean value (yes/no, true/false, ...) ...
((= vlax-vbBoolean VariantType)
;; Convert it to the string "True" or "False"
(if (= :vlax-true (vlax-variant-value VariantItem))
"True"
"False"
)
)
;; Otherwise, just turn vlax-variant-value loose on it
(t (vlax-variant-value VariantItem))
)
)
;;; A function to convert a Julian-like date, time, or date/time
;;; to a string.
;;; Argument: A real number, containing a Julian-type date based
;;; on January 1, 1900 (e.g. a Microsoft Access date) in the
;;; integer portion and a time (as a fraction of a day) in the
;;; fractional portion. Note that this algorithm considers a
;;; number with no fractional portion to be the day _starting_
;;; at midnight.
;;; Return Value: A string:
;;; Containing just the date if there was no fractional portion.
;;; Containing just the time if there was no integer portion or
;;; the input number was 0.0
;;; Otherwise, containing the date and the time.
;;; Times are returned as hour:minutes:seconds, 24-hour format,
;;; with leading zeros if necessary to make two digits per
;;; element
;;; Dates are returned in US format (month/day/year) but this
;;; is easily changed. The year is given as four digits.
;;; The month and day are supplied as two digits (possibly
;;; with leading zeros)
(defun 1900BasedJulianToCalender (JulianDate / a b c d e y z Month Day
Year Hours Minutes Seconds
CalenderTime NoTime NoDate ReturnValue
)
;; Initialize the return value
(setq ReturnValue "")
;; If the input date has no time component ...
(if (equal 0.0
(float (- JulianDate (float (fix JulianDate))))
1E-9
)
;; It has no time component ... if it has no date component ...
(if (zerop (fix JulianDate))
;; It must be a timestamp of 0:00.00. Set the flag that
;; we don't have a date but leave the "No Time" flag unset
(setq NoDate T)
;; It has a date component but has no time component.
;; Shift the date to a real Julian date
(setq JulianDate (+ 2415019 (fix JulianDate))
;; Set a flag so we know we don't have to calculate the
;; time
NoTime T
)
)
;; It has a time component. If it has no date component ...
(if (zerop (fix JulianDate))
;; Set a flag so we know we don't want to calculate a date
(setq NoDate T)
;; Otherwise, just shift it to be based like a standard
;; Julian date
(setq JulianDate (+ 2415019 JulianDate))
)
)
;; If we want to calculate the date ...
(if (not NoDate)
;; It's magic, don't even ask (because I don't know).
;; Some things we weren't meant to know.
(setq z (fix JulianDate)
a (fix (/ (- z 1867216.25) 36524.25))
a (+ z 1 a (- (fix (/ a 4))))
b (+ a 1524)
c (fix (/ (- b 122.1) 365.25))
d (floor (* 365.25 c))
e (fix (/ (- b d) 30.6001))
Day (fix (- b d (floor (* 30.6001 e))))
e (- e
(if (< e 14)
2
14
)
)
Month (1+ e)
Year (if (> e 1)
(- c 4716)
(- c 4715)
)
Year (if (= Year 0)
(1- Year)
Year
)
;; This uses US format for the date, you might want to
;; change it.
ReturnValue (strcat (if (< Month 10)
(strcat "0" (itoa Month))
(itoa Month)
)
"/"
(if (< Day 10)
(strcat "0" (itoa Day))
(itoa Day)
)
"/"
(itoa Year))
)
)
;; If we want to calculate the time ...
(if (not NoTime)
;; First strip the date portion from the input
(setq y (- JulianDate (float (fix JulianDate)))
;; Round to the nearest second
y (/ (float (fix (+ 0.5 (* y 86400.0)))) 86400.0)
;; Number of hours since midnight
Hours (fix (* y 24))
;; Number of minutes since midnight the hour
;; (1440 minutes per day)
Minutes (fix (- (* y 1440.0) (* Hours 60.0)))
;; Number of seconds since the minute (86400
;; seconds per day)
Seconds (fix (- (* y 86400.0) (* Hours 3600.0) (* Minutes 60.0)))
CalenderTime (strcat (if (< Hours 10)
(strcat "0" (itoa Hours))
(itoa Hours)
)
":"
(if (< Minutes 10)
(strcat "0" (itoa Minutes))
(itoa Minutes)
)
":"
(if (< Seconds 10)
(strcat "0" (itoa Seconds))
(itoa Seconds)
)
)
ReturnValue (if (< 0 (strlen ReturnValue))
(strcat ReturnValue " " CalenderTime)
CalenderTime
)
)
)
ReturnValue
)
;;; Floor function, rounds down to the next integer. Identical with
;;; FIX for positive numbers, but rounds away from zero for negative
;;; numbers.
(defun floor (number /)
(if (> number 0)
(fix number)
(fix (- number 1))
)
)
(prompt "\nADO example loaded") |
|
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
提升卡
置顶卡
沉默卡
变色卡
千斤顶
