一个普通的数据库例子源源程序

     To assist in interfacing with databases. This script can format variables and return SQL formats. Such as double quoting apposterphies and surrounding strings with quotes, Returning NULL for invalid data types, trimming strings so they do not exceed maximum lengths. This also has some functions so that you can open and close databases more conveiently with just one line of code. You can query a database and get an Array as well with some code.    Can't Copy and Paste this? Click here for a copy-and-paste friendly version of this code!     '**************************************     ' for :Common Database Routines     '**************************************     Copyright (c) 1999 by Lewis Moten, All rights reserved. code: Can't Copy and Paste this? Click here for a copy-and-paste friendly version of this code!     '**************************************     ' Name: Common Database Routines     ' Description:To assist in interfacing w     '     ith databases. This script can format va     '     riables and return SQL formats. Such as     '     double quoting apposterphies and surroun     '     ding strings with quotes, Returning NULL     '     for invalid data types, trimming strings     '     so they do not exceed maximum lengths. T     '     his also has some functions so that you     '     can open and close databases more convei     '     ently with just one line of code. You ca     '     n query a database and get an Array as w     '     ell with some code.     ' By: Lewis Moten     '     '     ' Inputs:None     '     ' Returns:None     '     'Assumes:This script assumes that you at     '     least have Microsoft ActiveX Data Object     '     s 2.0 or Higher (ADODB). This script may     '     get some getting used to at first until     '     you go through and study what each routi     '     ne can do.     '     'Side Effects:None     '     'Warranty:     'code provided by Planet Source Code(tm)     '     (www.Planet-Source-Code.com) 'as is', wi     '     thout warranties as to performance, fitn     '     ess, merchantability,and any other warra     '     nty (whether expressed or implied).     'Terms of Agreement:     'By using this source code, you agree to     '     the following terms...     ' 1) You may use this source code in per     '     sonal projects and may compile it into a     '     n .exe/.dll/.ocx and distribute it in bi     '     nary format freely and with no charge.     ' 2) You MAY NOT redistribute this sourc     '     e code (for example to a web site) witho     '     ut written permission from the original     '     author.Failure to do so is a violation o     '     f copyright laws.     ' 3) You may link to this code from anot     '     her website, provided it is not wrapped     '     in a frame.     ' 4) The author of this code may have re     '     tained certain additional copyright righ     '     ts.If so, this is indicated in the autho     '     r's description.     '**************************************                0 Then     ' Trim expression To maximum length     asExpression = Left(asExpression, anMaxLength)     End If ' anMaxLength > 0     ' Double quote SQL quote characters     asExpression = Replace(asExpression, '", ''")     ' If Expression is Empty     If asExpression = " Then     ' Return a NULL value     SQLPrep_s = NULL"     ' Else expression is Not empty     Else     ' Return quoted expression     SQLPrep_s = '" & asExpression & '"     End If ' asExpression     End Function ' SQLPrep_s     '---------------------------------------     '     ----------------------------------------     '          Public Function SQLPrep_n(ByVal anExpression)     ' If expression numeric     If IsNumeric(anExpression) And Not anExpression = " Then     ' Return number     SQLPrep_n = anExpression     ' Else expression Not numeric     Else     ' Return NULL     SQLPrep_n = NULL"     End If ' IsNumeric(anExpression) And Not anExpression = "     End Function ' SQLPrep_n     '---------------------------------------     '     ----------------------------------------     '          Public Function SQLPrep_b(ByVal abExpression, ByRef abDefault)     ' Declare Database Constants     Const lbTRUE = -1 '1 = SQL, -1 = Access     Const lbFALSE = 0     Dim lbResult ' Result To be passed back     ' Prepare For any errors that may occur     On Error Resume Next     ' If expression Not provided     If abExpression = " Then     ' Set expression To default value     abExpression = abDefault     End If ' abExpression = "     ' Attempt To convert expression     lbResult = CBool(abExpression)     ' If Err Occured     If Err Then     ' Clear the Error     Err.Clear     ' Determine action based on Expression     Select Case LCase(abExpression)     ' True expressions     Case yes", on", true", -1", 1"     lbResult = True     ' False expressions     Case no", off", false", 0"     lbResult = False     ' Unknown expression     Case Else     lbResult = abDefault     End Select ' LCase(abExpression)     End If ' Err     ' If result is True     If lbResult Then     ' Return True     SQLPrep_b = lbTRUE     ' Else Result is False     Else     ' Return False     SQLPrep_b = lbFALSE     End If ' lbResult     End Function ' SQLPrep_b     '---------------------------------------     '     ----------------------------------------     '          Public Function SQLPrep_d(ByRef adExpression)     ' If Expression valid Date     If IsDate(adExpression) Then     ' Return Date     'SQLPrep_d = '" & adExpression & '" ' SQL Database     SQLPrep_d = #" & adExpression & #" ' Access Database     ' Else Expression Not valid Date     Else     ' Return NULL     SQLPrep_d = NULL"     End If ' IsDate(adExpression)     End Function ' SQLPrep_d     '---------------------------------------     '     ----------------------------------------     '          Public Function SQLPrep_c(ByVal acExpression)     ' If Empty Expression     If acExpression = " Then     ' Return Null     SQLPrep_c = NULL"     ' Else expression has content     Else     ' Prepare For Errors     On Error Resume Next     ' Attempt To convert expression to Currency     SQLPRep_c = CCur(acExpression)     ' If Error occured     If Err Then     ' Clear Error     Err.Clear     SQLPrep_c = NULL"     End If ' Err     End If ' acExpression = "     End Function ' SQLPrep_c     '---------------------------------------     '     ----------------------------------------     '          Function buildJoinStatment(sTable,sFldLstAry,rs,conn)     Dim i,sSql,sTablesAry,sJnFldsAry,bJoinAry,sJoinDisplay     ReDim sTablesAry(UBound(sFldLstAry))     ReDim sJnFldsAry(UBound(sFldLstAry))     ReDim bJoinAry(UBound(sFldLstAry))     For i = 0 To UBound(sFldLstAry)     sSql = SELECT OBJECT_NAME(rkeyid),COL_NAME(rkeyid,rkey1)"     sSql = sSql &" FROM sysreferences"     sSql = sSql &" WHERE fkeyid = OBJECT_ID('"& sTable &"')     sSql = sSql &" AND col_name(fkeyid,fkey1) = '"& Trim(sFldLstAry(i)) &"'"     rs.open sSql,conn     If Not rs.eof Then     sTablesAry(i) = rs(0)     sJnFldsAry(i) = rs(1)     End If     rs.close     Next     If UBound(sFldLstAry) >= 0 Then     For i = 0 To UBound(sFldLstAry)     If sTablesAry(i) " Then     bJoinAry(i) = True     Else     bJoinAry(i) = False     End If     If i UBound(sFldLstAry) Then sSql = sSql &" +' - '+     Next     sSql = FROM & sTable     For i = 0 To UBound(sFldLstAry)     If bJoinAry(i) Then sSql = sSql &" LEFT JOIN & sTablesAry(i) &" ON & sTable &"."& sFldLstAry(i) &" = & sTablesAry(i) &"."& sJnFldsAry(i)     Next     End If     buildJoinStatment = sSql     End Function     '---------------------------------------     '     ----------------------------------------     '          Function buildQuery(ByRef asFieldAry, ByVal asKeyWords)     ' To find fields that may have a word in them     ' OR roger     ' | roger     ' roger     ' To find fields that must match a word     ' AND roger     ' + roger     ' & roger     ' To find fields that must Not match a word     ' Not roger     ' - roger     ' Also use phrases     ' +"rogers dog" -cat     ' +(rogers dog)     Dim loRegExp     Dim loRequiredWords     Dim loUnwantedWords     Dim loOptionalWords     Dim lsSQL     Dim lnIndex     Dim lsKeyword     Set loRegExp = New RegExp     loRegExp.Global = True     loRegExp.IgnoreCase = True     loRegExp.Pattern = ((AND|[+&])\s*[\(\[\{""].*[\)\]\}""])|((AND\s|[+&])\s*\b[-\w']+\b)"     Set loRequiredWords = loRegExp.Execute(asKeywords)     asKeywords = loRegExp.Replace(asKeywords, ")     loRegExp.Pattern = (((NOT|[-])\s*)?[\(\[\{""].*[\)\]\}""])|(((NOT\s+|[-])\s*)\b[-\w']+\b)"     Set loUnwantedWords = loRegExp.Execute(asKeywords)     asKeywords = loRegExp.Replace(asKeywords, ")     loRegExp.Pattern = (((OR|[|])\s*)?[\(\[\{""].*[\)\]\}""])|(((OR\s+|[|])\s*)?\b[-\w']+\b)"     Set loOptionalWords = loRegExp.Execute(asKeywords)     asKeywords = loRegExp.Replace(asKeywords, ")     If Not loRequiredWords.Count = 0 Then     ' REQUIRED     lsSQL = lsSQL & ("     For lnIndex = 0 To loRequiredWords.Count - 1     lsKeyword = loRequiredWords.Item(lnIndex).Value     loRegExp.Pattern = ^(AND|[+&])\s*"     lsKeyword = loRegExp.Replace(lsKeyword, ")     loRegExp.Pattern = [()""\[\]{}]"     lsKeyword = loRegExp.Replace(lsKeyword, ")     lsKeyword = Replace(lsKeyword, '", ''")     If Not lnIndex = 0 Then     lsSQL = lsSQL & AND      End If     lsSQL = lsSQL & (" & Join(asFieldAry, LIKE '%" & lsKeyword & %' OR ) & LIKE '%" & lsKeyword & %')"     Next     lsSQL = lsSQL & )"     End If     If Not loOptionalWords.Count = 0 Then     ' OPTIONAL     If lsSQL = " Then     lsSQL = lsSQL & ("     Else     lsSQL = lsSQL & AND ("     End If     For lnIndex = 0 To loOptionalWords.Count - 1     lsKeyword = loOptionalWords.Item(lnIndex).Value     loRegExp.Pattern = ^(OR|[|])\s*"     lsKeyword = loRegExp.Replace(lsKeyword, ")     loRegExp.Pattern = [()""\[\]{}]"     lsKeyword = loRegExp.Replace(lsKeyword, ")     lsKeyword = Replace(lsKeyword, '", ''")     If Not lnIndex = 0 Then     lsSQL = lsSQL & OR     End If     lsSQL = lsSQL & (" & Join(asFieldAry, LIKE '%" & lsKeyword & %' OR ) & LIKE '%" & lsKeyword & %')"     Next     lsSQL = lsSQL & )"     End If     If Not loUnwantedWords.Count = 0 Then     ' UNWANTED     If lsSQL = " Then     lsSQL = lsSQL & NOT ("     Else     lsSQL = lsSQL & AND Not ("     End If     For lnIndex = 0 To loUnwantedWords.Count - 1     lsKeyword = loUnWantedWords.Item(lnIndex).Value     loRegExp.Pattern = ^(NOT|[-])\s*"     lsKeyword = loRegExp.Replace(lsKeyword, ")     loRegExp.Pattern = [()""\[\]{}]"     lsKeyword = loRegExp.Replace(lsKeyword, ")     lsKeyword = Replace(lsKeyword, '", ''")     If Not lnIndex = 0 Then     lsSQL = lsSQL & OR     End If     lsSQL = lsSQL & (" & Join(asFieldAry, LIKE '%" & lsKeyword & %' OR ) & LIKE '%" & lsKeyword & %')"     Next     lsSQL = lsSQL & )"     End If     If Not lsSQL = " Then lsSQL = (" & lsSQL & )"     buildQuery = lsSQL     End Function     '---------------------------------------     '     ----------------------------------------     '          %>