3 ' ----------------------------------------------------------------------
\r
5 ' Page : dbClass2.vbs
\r
6 ' Description : Routines to access a SQL database using ADO
\r
7 ' Author : Matt Brown (dowdybrown@yahoo.com)
\r
8 ' Copyright (C) 2006-2008 Matt Brown
\r
10 ' Rico is licensed under the Apache License, Version 2.0 (the "License"); you may not use this
11 ' file except in compliance with the License. You may obtain a copy of the License at
12 ' http://www.apache.org/licenses/LICENSE-2.0
14 ' ----------------------------------------------------------------------
\r
16 '********************************************************************************************************
\r
17 ' Parse SQL a statement
\r
18 '********************************************************************************************************
\r
21 public arSelList,arSelListAs,FromClause,WhereClause,arGroupBy,HavingClause,arOrderBy,IsDistinct
\r
24 Public function ToArray()
\r
25 ToArray=Array(arSelList,arSelListAs,FromClause,WhereClause,arGroupBy,HavingClause,arOrderBy,IsDistinct)
\r
28 Public Sub LoadArray(a)
\r
39 ' -------------------------------------------------------------
\r
40 ' Rebuilds a SQL select statement that was parsed by ParseSelect
\r
41 ' -------------------------------------------------------------
\r
42 Private function Unparse(arSkipCols)
\r
45 if IsDistinct then sqltext=sqltext & "DISTINCT "
\r
46 sqltext=sqltext & UnparseColumnListSkip(arSkipCols) & " FROM " & FromClause
\r
47 if not IsEmpty(WhereClause) then sqltext=sqltext & " WHERE " & WhereClause
\r
48 if IsArray(arGroupBy) then
\r
49 if UBound(arGroupBy)>=0 then sqltext=sqltext & " GROUP BY " & join(arGroupBy,",")
\r
51 if not IsEmpty(HavingClause) then sqltext=sqltext & " HAVING " & HavingClause
\r
52 if IsArray(arOrderBy) then
\r
53 if UBound(arOrderBy)>=0 then sqltext=sqltext & " ORDER BY " & join(arOrderBy,",")
\r
59 Public function UnparseSelect()
\r
60 UnparseSelect=Unparse(array())
\r
64 Public function UnparseSelectSkip(arSkipCols)
\r
65 UnparseSelectSkip=Unparse(arSkipCols)
\r
69 Public function UnparseSelectDistinct()
\r
71 UnparseSelectDistinct=Unparse(array())
\r
75 Public function UnparseDistinctColumn(colnum)
\r
77 sqltext="SELECT DISTINCT " & arSelList(colnum) & " FROM " & FromClause
\r
78 if not IsEmpty(WhereClause) then sqltext=sqltext & " WHERE " & WhereClause
\r
79 sqltext=sqltext & " ORDER BY " & arSelList(colnum)
\r
80 UnparseDistinctColumn=sqltext
\r
84 Public function UnparseColumn(ByVal i)
\r
87 if not IsEmpty(arSelListAs(i)) then s=s & " AS " & arSelListAs(i)
\r
92 Public function UnparseColumnList()
\r
93 UnparseColumnList=UnparseColumnListSkip(array())
\r
97 Public function UnparseColumnListSkip(arSkipCols)
\r
98 dim sqltext,i,SkipIdx,skip
\r
100 for i=0 to ubound(arSelList)
\r
102 if SkipIdx <= ubound(arSkipCols) then
\r
103 skip=CBool(arSkipCols(SkipIdx)=CStr(i))
\r
104 if skip then SkipIdx=SkipIdx+1
\r
107 if not IsEmpty(sqltext) then sqltext=sqltext & ","
\r
108 sqltext=sqltext & arSelList(i) & " AS rico_col" & i
\r
111 UnparseColumnListSkip=sqltext
\r
115 Public Sub DebugPrint()
\r
117 response.write "<p>Parse Result:"
\r
118 response.write "<table border='1'>"
\r
119 if IsDistinct then response.write "<tr valign='top'><td>DISTINCT<td> "
\r
120 response.write "<tr valign='top'><td>COLUMNS:<td><ol>"
\r
121 for i=0 to ubound(arSelList)
\r
122 response.write "<li>" & UnparseColumn(i)
\r
124 response.write "</ol><tr valign='top'><td>FROM:<td>" & FromClause
\r
125 if not IsEmpty(WhereClause) then response.write "<tr valign='top'><td>WHERE:<td>" & WhereClause
\r
126 if IsArray(arGroupBy) then
\r
127 if UBound(arGroupBy)>=0 then response.write "<tr valign='top'><td>GROUP BY:<td>" & join(arGroupBy,"<br>")
\r
129 if not IsEmpty(HavingClause) then response.write "<tr valign='top'><td>HAVING:<td>" & HavingClause
\r
130 if IsArray(arOrderBy) then
\r
131 if UBound(arOrderBy)>=0 then response.write "<tr valign='top'><td>ORDER BY:<td>" & join(arOrderBy,"<br>")
\r
133 response.write "</table>"
\r
137 Public sub Init(ub)
\r
138 redim arSelList(ub),arSelListAs(ub),arGroupBy(-1),arOrderBy(-1)
\r
146 ' -------------------------------------------------------------
\r
147 ' Parse a SQL select statement into its major components
\r
151 ' 3) more than one space between "group" and "by", or "order" and "by"
\r
152 ' If distinct is specified, it will be part of the first item in arSelList
\r
153 ' -------------------------------------------------------------
\r
154 Public function ParseSelect(ByVal sqltext)
\r
155 dim i,j,l,idx,clause,parencnt,inquote,endquote,ch,curfield,nexttoken
\r
158 sqltext=replace(sqltext,vbLf," ")
\r
159 sqltext=" " & replace(sqltext,vbCr," ") & " SELECT " ' SELECT suffix forces last curfield to be saved
\r
160 'response.write "<p>ParseSelect: " & sqltext & "</p>"
\r
167 ch=mid(sqltext,i,1)
\r
169 if ch=endquote then
\r
170 if endquote="'" and mid(sqltext,i,2)="''" then
\r
171 curfield=curfield & "'"
\r
177 curfield=curfield & ch
\r
178 elseif ch="'" or ch="""" or ch="`" then
\r
181 curfield=curfield & ch
\r
185 curfield=curfield & ch
\r
187 parencnt=parencnt+1
\r
188 curfield=curfield & ch
\r
190 if parencnt=0 then exit function ' sql statement has a syntax error
\r
191 parencnt=parencnt-1
\r
192 curfield=curfield & ch
\r
193 elseif parencnt > 0 then
\r
194 curfield=curfield & ch
\r
196 'response.write "<p>" & clause & ": " & server.htmlencode(curfield) & "</p>"
\r
199 SetParseField arSelList,curfield
\r
200 Push arSelListAs,Empty
\r
202 arSelListAs(ubound(arSelList))=curfield
\r
205 case "GROUP BY": SetParseField arGroupBy,curfield
\r
206 case "ORDER BY": SetParseField arOrderBy,curfield
\r
207 case else: curfield=curfield & ch
\r
210 j=InStr(i+1,sqltext," ")
\r
212 curfield=curfield & ch
\r
214 if ucase(mid(sqltext,j+1,3))="BY " then j=j+3
\r
215 nexttoken=ucase(mid(sqltext,i+1,j-i-1))
\r
216 'wscript.echo "'" & nexttoken & "'"
\r
217 'response.write "<p>" & clause & " : " & nexttoken & " : " & server.htmlencode(curfield) & "</p>"
\r
218 select case nexttoken
\r
219 case "SELECT","INTO","FROM","WHERE","GROUP BY","HAVING","ORDER BY":
\r
222 AddColumn curfield,Empty
\r
225 arSelListAs(ubound(arSelList))=curfield
\r
227 case "FROM": SetParseField FromClause,curfield
\r
228 case "WHERE": SetParseField WhereClause,curfield
\r
229 case "GROUP BY": SetParseField arGroupBy,curfield
\r
230 case "HAVING": SetParseField HavingClause,curfield
\r
231 case "ORDER BY": SetParseField arOrderBy,curfield
\r
236 if clause="SELECT" then
\r
237 AddColumn curfield,Empty
\r
241 elseif curfield<>"" then
\r
242 curfield=curfield & ch
\r
245 if clause="SELECT" then
\r
249 elseif curfield<>"" then
\r
250 curfield=curfield & ch
\r
252 case else: if curfield<>"" then curfield=curfield & ch
\r
256 curfield=curfield & ch
\r
264 Private sub Push(f, ByVal newvalue)
\r
265 ReDim Preserve f(ubound(f)+1)
\r
266 f(ubound(f))=newvalue
\r
269 Private sub SetParseField(f, ByRef newvalue)
\r
278 ' -------------------------------------------------------------
\r
279 ' Add column to select list
\r
280 ' -------------------------------------------------------------
\r
281 Public Sub AddColumn(ByVal ColumnSql, ByVal ColumnName)
\r
282 Push arSelList,ColumnSql
\r
283 Push arSelListAs,ColumnName
\r
286 Public Function LastColumn()
\r
287 LastColumn=arSelList(ubound(arSelList))
\r
290 ' -------------------------------------------------------------
\r
291 ' Add a join to the from clause
\r
292 ' -------------------------------------------------------------
\r
293 Public Sub AddJoin(ByVal JoinClause)
\r
294 if InStr(FromClause," join ")>0 then FromClause="(" & FromClause & ")" ' required by Access
\r
295 FromClause=FromClause & " " & JoinClause
\r
298 Private Sub SplitSortSpec(ByVal sortspec, ByRef sortcol, ByRef sortdir)
\r
299 sortspec=ucase(sortspec)
\r
300 if right(sortspec,3)="ASC" then
\r
301 sortcol=trim(left(sortspec,len(sortspec)-3))
\r
303 elseif right(sortspec,4)="DESC" then
\r
304 sortcol=trim(left(sortspec,len(sortspec)-4))
\r
307 sortcol=trim(sortspec)
\r
312 Private Function FindSortColumn(ByVal sortspec)
\r
313 dim i, findcol, finddir, sortcol, sortdir
\r
315 SplitSortSpec sortspec, findcol, finddir
\r
316 for i=0 to ubound(arOrderBy)
\r
317 SplitSortSpec arOrderBy(i), sortcol, sortdir
\r
318 if sortcol=findcol then
\r
325 ' -------------------------------------------------------------
\r
326 ' Add sort criteria to the beginning of the order by clause
\r
327 ' -------------------------------------------------------------
\r
328 Public Sub AddSort(ByVal NewSort)
\r
330 colidx=FindSortColumn(NewSort)
\r
332 for i=colidx to 1 step -1
\r
333 arOrderBy(i)=arOrderBy(i-1)
\r
335 arOrderBy(0)=NewSort
\r
337 ReDim Preserve arOrderBy(ubound(arOrderBy)+1)
\r
338 for i=ubound(arOrderBy) to 1 step -1
\r
339 arOrderBy(i)=arOrderBy(i-1)
\r
341 arOrderBy(0)=NewSort
\r
345 ' -------------------------------------------------------------
\r
346 ' Append sort criteria to the order by clause
\r
347 ' -------------------------------------------------------------
\r
348 Public Sub AppendSort(ByVal NewSort)
\r
349 Push arOrderBy,NewSort
\r
352 ' -------------------------------------------------------------
\r
353 ' Add a condition to the where clause
\r
354 ' -------------------------------------------------------------
\r
355 Public Sub AddWhereCondition(ByVal NewCondition)
\r
356 AddCondition WhereClause,NewCondition
\r
359 ' -------------------------------------------------------------
\r
360 ' Add a condition to the having clause
\r
361 ' -------------------------------------------------------------
\r
362 Public Sub AddHavingCondition(ByVal NewCondition)
\r
363 AddCondition HavingClause,NewCondition
\r
366 Private Sub AddCondition(ByRef Clause, ByVal NewCondition)
\r
367 if IsEmpty(NewCondition) then exit sub
\r
368 If IsEmpty(Clause) Then
\r
369 Clause="(" & NewCondition & ")"
\r
371 Clause=Clause & " AND (" & NewCondition & ")"
\r
378 '********************************************************************************************************
\r
379 ' created by dbClass.GetColumnInfo()
\r
380 '********************************************************************************************************
\r
382 Public ColName,Nullable,ColType,ColLength,Writeable,IsPKey,FixedLength
\r
386 '********************************************************************************************************
\r
387 ' Manage a database connection
\r
388 '********************************************************************************************************
\r
391 Public SqlSvr,debug,ConnTimeout,CmdTimeout,LockTimeout,Provider,OdbcDriver
\r
392 Public ErrMsgFmt ' empty=errors not shown, otherwise "HTML" or "MULTILINE" or "1LINE"
\r
393 Public DisplayErrors ' true/false
\r
394 Public LastErrorMsg,Dialect
\r
396 Private dbMain,DisplayFunc,dbDefault
\r
398 ' -------------------------------------------------------------
\r
399 ' Class Constructor
\r
400 ' -------------------------------------------------------------
\r
401 Private Sub Class_Initialize ' Setup Initialize event.
\r
403 SqlSvr = "localhost"
\r
406 ConnTimeout=30 ' seconds
\r
407 LockTimeout=5000 ' milliseconds
\r
409 on error resume next ' if running with option explicit, then the next lines cause an error
\r
410 tw=TypeName(wscript)
\r
411 tr=TypeName(response)
\r
412 if tw<>"Empty" then
\r
413 if IsObject(wscript) then
\r
415 CmdTimeout = 3600 ' 60 minutes for wsh/cscript
\r
416 DisplayFunc="wscript.echo "
\r
418 elseif tr<>"Empty" then
\r
419 if IsObject(response) then
\r
421 CmdTimeout = 120 ' 2 minutes for asp pages
\r
422 DisplayFunc="response.write "
\r
425 ErrMsgFmt="MULTILINE"
\r
427 DisplayFunc="msgbox "
\r
429 'DisplayMsg "Message format set to " & ErrMsgFmt
\r
432 Public function Connection()
\r
433 set Connection=dbMain
\r
436 Public Sub Use_TSQL()
\r
438 Provider="SQLOLEDB"
\r
441 Public Sub Use_Access(FileName)
\r
443 Provider="Microsoft.Jet.OLEDB.4.0"
\r
447 Public Sub Use_MySQL()
\r
449 OdbcDriver="{MySQL ODBC 3.51 Driver}"
\r
452 Public Sub Use_Oracle(SIM)
\r
454 'Provider="MSDAORA"
\r
455 Provider="OraOLEDB.Oracle"
\r
459 Public function CurrentTime()
\r
460 select case Dialect
\r
461 case "TSQL","DB2": CurrentTime="CURRENT_TIMESTAMP"
\r
462 case "Access": CurrentTime="Now()"
\r
463 case else: CurrentTime="LOCALTIMESTAMP"
\r
467 Public function Convert2Char(s)
\r
468 select case Dialect
\r
469 case "TSQL" : Convert2Char="cast(" & s & " as varchar)"
\r
470 case "Access": Convert2Char="CStr(" & s & ")"
\r
471 case "DB2" : Convert2Char="CHAR(" & s & ")"
\r
472 case "MySQL" : Convert2Char="{fn CONVERT(" & s & ",CHAR)}" ' use ODBC's convert function
\r
473 case "Oracle": Convert2Char="cast(" & s & " as varchar2(20))"
\r
474 case else: Convert2Char=s ' implicit conversion
\r
478 Public function SqlDay(s)
\r
479 select case Dialect
\r
480 case "Oracle": SqlDay="to_char(" & s & ",'DD')"
\r
481 case "MySQL": SqlDay="dayofmonth(" & s & ")"
\r
482 case else: SqlDay="day(" & s & ")"
\r
486 Public function SqlMonth(s)
\r
487 select case Dialect
\r
488 case "Oracle": SqlMonth="to_char(" & s & ",'MM')"
\r
489 case else: SqlMonth="month(" & s & ")"
\r
493 Public function SqlYear(s)
\r
494 select case Dialect
\r
495 case "Oracle": SqlYear="to_char(" & s & ",'YYYY')"
\r
496 case else: SqlYear="year(" & s & ")"
\r
500 Public function Wildcard()
\r
504 Public function addQuotes(s)
\r
505 select case Dialect
\r
508 addQuotes="#" & s & "#"
\r
510 addQuotes="""" & replace(s,"""","""""") & """"
\r
512 case "MySQL": addQuotes="'" & replace(replace(s,"\","\\"),"'","\'") & "'"
\r
513 case else: addQuotes="'" & replace(s,"'","''") & "'"
\r
517 Public function Concat(arStrings,addQuotes)
\r
520 for i=0 to ubound(arStrings)
\r
521 arStrings(i)=addQuotes(arStrings(i))
\r
524 select case Dialect
\r
525 case "TSQL": Concat=join(arStrings,"+")
\r
526 case "Access": Concat=join(arStrings," & ")
\r
527 case "MySQL": Concat="concat(" & join(arStrings,",") & ")"
\r
528 case else: Concat=join(arStrings," || ")
\r
532 ' -------------------------------------------------------------
\r
534 ' -------------------------------------------------------------
\r
535 Private Sub Class_Terminate ' Setup Terminate event.
\r
539 ' -------------------------------------------------------------
\r
540 ' If the database is down, then an explanation can be placed here
\r
541 ' -------------------------------------------------------------
\r
542 Public function MaintenanceMsg()
\r
546 Public function DefaultDB()
\r
547 DefaultDB=dbDefault
\r
550 ' -------------------------------------------------------------
\r
551 ' Attempts to connect to the database using Windows security.
\r
552 ' Returns true on success.
\r
553 ' For use with MS SQL Server
\r
554 ' -------------------------------------------------------------
\r
555 Public function WinLogon(ByVal DefDB)
\r
558 if IsEmpty(OdbcDriver) Then
\r
559 connstr="Provider=" & Provider & ";Data Source=" & SqlSvr & ";Integrated Security=SSPI;"
\r
560 if DefDB<>"" then connstr=connstr & "Initial Catalog=" & DefDB & ";"
\r
562 connstr="DRIVER=" & OdbcDriver & ";SERVER=" & SqlSvr & ";Trusted_Connection=Yes;"
\r
563 if DefDB<>"" then connstr=connstr & "DATABASE=" & DefDB & ";"
\r
565 WinLogon=dbConnect(connstr)
\r
568 ' -------------------------------------------------------------
\r
569 ' Attempts to connect to the database using sql security model.
\r
570 ' Returns true on success.
\r
571 ' -------------------------------------------------------------
\r
572 Public function SqlLogon(ByVal DefDB, ByVal userid, ByVal pw)
\r
575 if IsEmpty(OdbcDriver) then
\r
576 connstr="Provider=" & Provider & ";Data Source=" & SqlSvr & ";"
\r
577 if userid<>"" then connstr=connstr & "User Id=" & userid & ";Password=" & pw & ";"
\r
578 if DefDB<>"" then connstr=connstr & "Initial Catalog=" & DefDB & ";"
\r
580 connstr="DRIVER=" & OdbcDriver & ";SERVER=" & SqlSvr & ";"
\r
581 if userid<>"" then connstr=connstr & "USER=" & userid & ";PASSWORD=" & pw & ";"
\r
582 if DefDB<>"" then connstr=connstr & "DATABASE=" & DefDB & ";"
\r
584 SqlLogon=dbConnect(connstr)
\r
587 ' -------------------------------------------------------------
\r
588 ' Attempts to connect to the Database. Returns true on success.
\r
589 ' -------------------------------------------------------------
\r
590 Public function dbConnect(ByVal ConnStr)
\r
591 if MaintenanceMsg<>"" then
\r
592 HandleError MaintenanceMsg
\r
595 On Error Resume Next
\r
597 if not IsObject(dbMain) then
\r
598 set dbMain = CreateObject("ADODB.Connection")
\r
599 if CheckForError("creating ADODB object") then exit function
\r
601 if debug then DisplayMsg "Connect String: " & ConnStr
\r
602 dbMain.ConnectionTimeout = ConnTimeout
\r
603 dbMain.Open ConnStr
\r
604 if CheckForError("opening connection: " & ConnStr) then exit function
\r
605 dbMain.CommandTimeout = CmdTimeout
\r
606 if Dialect="TSQL" then RunActionQuery "SET LOCK_TIMEOUT " & LockTimeout
\r
610 ' -------------------------------------------------------------
\r
611 ' Close database connection
\r
612 ' -------------------------------------------------------------
\r
614 if IsObject(dbMain) then
\r
615 if dbMain.state <> 0 then dbMain.Close
\r
616 set dbMain = Nothing ' releases memory, but still an object
\r
617 dbMain = Empty ' cause IsObject to return false
\r
621 ' -------------------------------------------------------------
\r
622 ' return true if database connection is open
\r
623 ' -------------------------------------------------------------
\r
624 Public Function dbIsOpen
\r
626 if IsObject(dbMain) then
\r
627 if dbMain.state <> 0 then dbIsOpen=true
\r
631 ' -------------------------------------------------------------
\r
632 ' Return a string containing an error message
\r
633 ' String format is based on ErrMsgFmt
\r
634 ' -------------------------------------------------------------
\r
635 Private Function FormatErrorMsg(ByVal ContextMsg)
\r
636 select case ErrMsgFmt
\r
637 case "HTML": FormatErrorMsg = "<p class='dberror' id='dbError'>Error # " & Hex(err.number) & " was generated by " & err.Source & "<br />" & FixHtmlStr(err.Description) & "</p>" & _
\r
638 "<p class='dberror' id='dbErrorDetail'><u>Operation that caused the error:</u><br />" & FixHtmlStr(ContextMsg) & "</p>"
\r
639 case "MULTILINE": FormatErrorMsg = "Error # " & Hex(err.number) & " was generated by " & err.Source & vbLf & err.Description & vbLf & vbLf & _
\r
640 "Operation that caused the error:" & vbLf & ContextMsg
\r
641 case "1LINE": FormatErrorMsg = "Error # " & hex(Err.Number) & " was generated by " & Err.Source & ": " & Err.Description & " (" & ContextMsg & ")"
\r
645 Private Function FixHtmlStr(s)
\r
646 FixHtmlStr=replace(replace(replace(s,"&","&"),"<","<"),"""",""")
\r
649 Private sub DisplayMsg(msg)
\r
650 if not IsEmpty(DisplayFunc) then
\r
651 if ErrMsgFmt="HTML" and left(msg,1)<>"<" then
\r
652 msg="<p>" & Server.HTMLEncode(replace(msg,vbLf,"<br>"))
\r
654 msg=replace(msg,vbLf," ")
\r
656 execute DisplayFunc & """" & replace(msg,"""","""""") & """"
\r
660 Private sub HandleError(msg)
\r
662 if DisplayErrors then DisplayMsg LastErrorMsg
\r
665 ' -------------------------------------------------------------
\r
666 ' Checks if an error has occurred, and if so, displays a message & returns true
\r
667 ' -------------------------------------------------------------
\r
668 Private function CheckForError(msg)
\r
669 CheckForError=false
\r
670 If err.number = 0 Then exit function
\r
672 if IsEmpty(ErrMsgFmt) Then exit function
\r
673 HandleError FormatErrorMsg(msg)
\r
676 ' -------------------------------------------------------------
\r
677 ' Runs a query and moves to the first record.
\r
678 ' Use only for queries that return records (no updates or deletes).
\r
679 ' If the query generated an error then Nothing is returned, otherwise it returns a new recordset object.
\r
680 ' -------------------------------------------------------------
\r
681 Public Function RunQuery(sqltext)
\r
683 On Error Resume Next
\r
684 Set rsLookUp = dbMain.Execute(sqltext)
\r
685 If CheckForError(sqltext) Then
\r
686 Set RunQuery = Nothing
\r
689 If debug then DisplayMsg sqltext
\r
690 If Not rsLookUp.EOF Then rsLookUp.MoveFirst
\r
691 Set RunQuery = rsLookUp
\r
695 ' -------------------------------------------------------------
\r
696 ' Runs a parameterized query (put ? in sqltext to indicate where parameters should be inserted)
\r
697 ' Use only for queries that return records (no updates or deletes).
\r
698 ' If the query generated an error then Nothing is returned, otherwise it returns a new recordset object.
\r
699 ' -------------------------------------------------------------
\r
700 Public Function RunParamQuery(sqltext, arParams)
\r
701 Dim rsLookUp,cmd,RecordsAffected
\r
702 On Error Resume Next
\r
703 set objCmd = CreateObject("ADODB.Command")
\r
704 Set objCmd.ActiveConnection = dbMain
\r
705 objCmd.CommandText = sqltext
\r
706 objCmd.CommandType = 1 ' adCmdText
\r
707 Set rsLookUp = objCmd.Execute(RecordsAffected,arParams)
\r
708 If CheckForError(sqltext) Then
\r
709 Set RunParamQuery = Nothing
\r
712 If debug then DisplayMsg sqltext
\r
713 set objCmd = Nothing
\r
714 Set RunParamQuery = rsLookUp
\r
718 ' -------------------------------------------------------------
\r
719 ' Safely close a recordset
\r
720 ' -------------------------------------------------------------
\r
721 Public Sub rsClose(ByRef rsLookUp)
\r
722 If IsObject(rsLookUp) Then
\r
723 If Not (rsLookUp Is Nothing) Then
\r
724 If rsLookUp.State <> 0 Then ' adStateClosed=0
\r
727 Set rsLookUp = Nothing
\r
732 ' -------------------------------------------------------------
\r
733 ' Runs a query and returns results from the first record in dicData.
\r
734 ' Returns true if dicData is modified (ie. a record exists).
\r
735 ' If the query generates an error then dicData is left unchanged
\r
736 ' dicData can be a dictionary object, an array, or a scalar
\r
737 ' If dicData is a scalar, it will be assigned the value of the first field in the first row.
\r
738 ' -------------------------------------------------------------
\r
739 Public Function SingleRecordQuery(ByVal sqltext, ByRef dicData)
\r
741 SingleRecordQuery = False
\r
742 Set rsMain = RunQuery(sqltext)
\r
743 If rsMain Is Nothing Then Exit Function
\r
744 If Not rsMain.EOF Then
\r
745 If IsObject(dicData) Then
\r
746 For i = 0 To rsMain.Fields.Count - 1
\r
747 dicData(rsMain.Fields(i).name) = rsMain.Fields(i).Value
\r
749 ElseIf IsArray(dicData) Then
\r
750 For i = 0 To rsMain.Fields.Count - 1
\r
751 dicData(i) = rsMain.Fields(i).Value
\r
754 dicData = rsMain.Fields(0).Value
\r
756 SingleRecordQuery = True
\r
762 ' -------------------------------------------------------------
\r
763 ' Runs a query where no result set is expected (updates, deletes, etc)
\r
764 ' - returns the number of records affected by the action query
\r
765 ' -------------------------------------------------------------
\r
766 Public Function RunActionQuery(ByVal sqltext)
\r
767 Dim RecordsAffected, spflag
\r
768 On Error Resume Next
\r
770 spflag = (UCase(Left(sqltext, 4)) = "EXEC")
\r
771 If spflag Then dbMain.Execute "SET NOCOUNT ON"
\r
772 dbMain.Execute sqltext, RecordsAffected, &H80 ' adExecuteNoRecords (hard coded so that adovbs.inc is not required)
\r
773 If CheckForError(sqltext) Then
\r
777 if not IsEmpty(RecordsAffected) and not IsNull(RecordsAffected) then
\r
778 DisplayMsg RecordsAffected & " records affected"
\r
781 RunActionQuery = RecordsAffected
\r
785 ' -------------------------------------------------------------
\r
786 ' Runs a query where no result set is expected (updates, deletes, etc)
\r
787 ' - if an error occurs, then the message is returned in errmsg
\r
788 ' -------------------------------------------------------------
\r
789 Public function RunActionQueryReturnMsg (ByVal sqltext, ByRef errmsg)
\r
790 dim tmpDisplayErrors
\r
791 tmpDisplayErrors=DisplayErrors
\r
792 DisplayErrors=false
\r
794 RunActionQueryReturnMsg=RunActionQuery(sqltext)
\r
795 if not IsEmpty(LastErrorMsg) then errmsg=LastErrorMsg
\r
796 DisplayErrors=tmpDisplayErrors
\r
800 ' -------------------------------------------------------------
\r
801 ' Takes a sql create (table or view) statement and performs:
\r
802 ' 1) a conditional drop (if it already exists)
\r
804 ' 3) grants select access to public (if not a temp table)
\r
806 ' for views, all actions must occur on the default database for the connection
\r
807 ' -------------------------------------------------------------
\r
808 Public sub DropCreate (sqlcreate)
\r
809 dim sqltext,shortname,parsed,arName,db
\r
810 parsed=split(sqlcreate," ",4)
\r
811 arName=split(parsed(2),".")
\r
812 shortname=arName(ubound(arName))
\r
813 if ubound(arName)=2 then db=arName(0) else db=dbDefault
\r
814 sqltext="IF EXISTS (SELECT * from " & db & ".dbo.sysobjects WHERE name='" & shortname & "') DROP " & parsed(1) & " " & parsed(2)
\r
815 RunActionQuery sqltext
\r
816 RunActionQuery sqlcreate
\r
817 if left(shortname,1) <> "#" and db=dbDefault then
\r
818 sqltext="GRANT SELECT ON " & parsed(2) & " TO public"
\r
819 RunActionQuery sqltext
\r
823 ' -------------------------------------------------------------
\r
824 ' Returns a recordset that will enumerate the columns in a table or view
\r
825 ' objname may be a fully qualified object name
\r
826 ' -------------------------------------------------------------
\r
827 Public function EnumColumns (ByVal objname)
\r
828 select case Dialect
\r
829 case "TSQL": set EnumColumns=RunQuery("exec sp_columns " & TabName2SpParms(objname))
\r
830 case "Access": set EnumColumns=empty
\r
831 case "MySQL": set EnumColumns=RunQuery("show full columns from " & objname)
\r
832 case else: set EnumColumns=RunQuery("describe " & objname)
\r
836 ' -------------------------------------------------------------
\r
837 ' Convert the numeric value returned by DB to Enum, so
\r
838 ' that at least the user could have a guess of what it is.
\r
839 ' -------------------------------------------------------------
\r
840 Public Function ConvType(ByVal TypeVal)
\r
841 Select Case TypeVal
\r
842 Case 20 ConvType = "adBigInt"
\r
843 Case 128 ConvType = "adBinary"
\r
844 Case 11 ConvType = "adBoolean"
\r
845 Case 8 ConvType = "adBSTR" ' i.e. null terminated string
\r
846 Case 129 ConvType = "adChar"
\r
847 Case 6 ConvType = "adCurrency"
\r
848 Case 7 ConvType = "adDate"
\r
849 Case 133 ConvType = "adDBDate"
\r
850 Case 134 ConvType = "adDBTime"
\r
851 Case 135 ConvType = "adDBTimeStamp"
\r
852 Case 14 ConvType = "adDecimal"
\r
853 Case 5 ConvType = "adDouble"
\r
854 Case 0 ConvType = "adEmpty"
\r
855 Case 10 ConvType = "adError"
\r
856 Case 72 ConvType = "adGUID"
\r
857 Case 9 ConvType = "adIDispatch"
\r
858 Case 3 ConvType = "adInteger"
\r
859 Case 13 ConvType = "adIUnknown"
\r
860 Case 205 ConvType = "adLongVarBinary"
\r
861 Case 201 ConvType = "adLongVarChar"
\r
862 Case 203 ConvType = "adLongVarWChar"
\r
863 Case 131 ConvType = "adNumeric"
\r
864 Case 4 ConvType = "adSingle"
\r
865 Case 2 ConvType = "adSmallInt"
\r
866 Case 16 ConvType = "adTinyInt"
\r
867 Case 21 ConvType = "adUnsignedBigInt"
\r
868 Case 19 ConvType = "adUnsignedInt"
\r
869 Case 18 ConvType = "adUnsignedSmallInt"
\r
870 Case 17 ConvType = "adUnsignedTinyInt"
\r
871 Case 132 ConvType = "adUserDefined"
\r
872 Case 204 ConvType = "adVarBinary"
\r
873 Case 200 ConvType = "adVarChar"
\r
874 Case 12 ConvType = "adVariant"
\r
875 Case 202 ConvType = "adVarWChar"
\r
876 Case 130 ConvType = "adWChar"
\r
880 ' -------------------------------------------------------------
\r
881 ' Refresh View - in case the tables on which the view is based have changed
\r
882 ' -------------------------------------------------------------
\r
883 Public sub RefreshView (ByVal viewname)
\r
884 dim sqltext,rsLookUp
\r
885 sqltext="SELECT * FROM " & dbDefault & ".dbo.sysobjects o " & vbLf & _
\r
886 "WHERE (o.xtype='V') AND (o.name='" & viewname & "')"
\r
887 set rsLookUp = RunQuery(sqltext)
\r
888 if rsLookUp.EOF then
\r
892 sqltext="sp_helptext '" & viewname & "'"
\r
893 set rsLookUp = RunQuery(sqltext)
\r
895 Do while not rsLookUp.EOF
\r
896 sqltext=sqltext & rsLookUp("Text")
\r
900 sqltext=replace(sqltext,"CREATE VIEW ","ALTER VIEW ",1,-1,1)
\r
901 RunActionQuery sqltext
\r
905 ' -------------------------------------------------------------
\r
906 ' Split a fully or partially qualified table name into
\r
907 ' its component parts (db,owner,table)
\r
908 ' -------------------------------------------------------------
\r
909 Public sub SplitTabName (ByVal objname, ByRef dbname, ByRef owner, ByRef table)
\r
912 arNames=split(objname,".")
\r
913 last=ubound(arNames)
\r
914 table=arNames(last)
\r
915 if Dialect="Access" or Dialect="Oracle" then
\r
922 owner=arNames(last-1)
\r
927 dbname=arNames(last-2)
\r
933 ' -------------------------------------------------------------
\r
934 ' Converts objname (db.owner.table) to format used by
\r
935 ' stored procedures ('table','owner','db')
\r
936 ' -------------------------------------------------------------
\r
937 Public function TabName2SpParms (ByVal objname)
\r
938 dim table,owner,dbname
\r
939 SplitTabName objname,dbname,owner,table
\r
940 TabName2SpParms="'" & table & "','" & owner & "','" & dbname & "'"
\r
944 ' -------------------------------------------------------------
\r
945 ' Safely add a column to a table
\r
946 ' -------------------------------------------------------------
\r
947 Public sub AddColumnIfMissing(TableName,ColumnName,ColumnType)
\r
948 dim sqltext,db,ShortName,arTableName
\r
950 arTableName=split(TableName,".")
\r
951 ShortName=arTableName(ubound(arTableName)) ' the last element is the unqualified table name
\r
952 if ubound(arTableName)=2 then db=arTableName(0) ' if TableName was a fully qualified name, then use the db name that came with it
\r
953 sqltext="IF NOT EXISTS (SELECT c.name FROM " & db & ".dbo.syscolumns c, " & db & ".dbo.sysobjects o " & vbLf & _
\r
954 "WHERE c.id = o.id AND (o.xtype='U') AND (o.name='" & ShortName & "') AND (c.name='" & ColumnName & "')) " & vbLf & _
\r
955 "ALTER TABLE " & TableName & " ADD " & ColumnName & " " & ColumnType
\r
956 RunActionQuery sqltext
\r
960 Private function ADOColType(typenum)
\r
961 select case typenum
\r
962 case 2,3,16,17,18,19,20,21,139: ADOColType="INT"
\r
963 case 7,133,134,135: ADOColType="DATETIME"
\r
964 case 129,130: ADOColType="CHAR"
\r
965 case 8,200,202: ADOColType="VARCHAR"
\r
966 case 201,203: ADOColType="TEXT"
\r
967 case 4,5,6,14: ADOColType="FLOAT"
\r
968 case 11: ADOColType="BOOLEAN"
\r
969 case else: ADOColType="???" & typenum
\r
973 ' -------------------------------------------------------------
\r
974 ' Returns a recordset that will enumerate the columns in a table or view
\r
975 ' objname may be a fully qualified object name
\r
976 ' querytype: 4=adSchemaColumns, 27=adSchemaForeignKeys, 28=adSchemaPrimaryKeys
\r
977 ' -------------------------------------------------------------
\r
978 Public function EnumColumnsADO (ByVal querytype, ByVal objname)
\r
979 dim table,owner,dbname,reval
\r
980 on error resume next
\r
981 SplitTabName objname,dbname,owner,table
\r
982 If debug then DisplayMsg "Getting ADO column info for: " & querytype & ", " & objname
\r
983 Set reval = dbMain.OpenSchema (querytype, Array(dbname, owner, table))
\r
984 if CheckForError("OpenSchema: " & querytype & "," & dbname & "," & owner & "," & table) then
\r
985 Set reval = Nothing
\r
987 Set EnumColumnsADO = reval
\r
991 '********************************************************************************************************
\r
992 ' Returns a comma-separated list of column names that make up the primary key
\r
993 ' Returns empty if no primary key has been defined
\r
994 '********************************************************************************************************
\r
995 Public function PrimaryKey(TableName)
\r
997 If debug then DisplayMsg "Getting primary key for: " & TableName
\r
998 Set rs = EnumColumnsADO(28,TableName)
\r
999 if rs is Nothing Then exit function
\r
1001 if IsEmpty(colnames) then colnames=rs("COLUMN_NAME") else colnames=colnames & "," & rs("COLUMN_NAME")
\r
1005 PrimaryKey=colnames
\r
1009 ' returns number of columns, or -1 if there was en error
\r
1010 Public function GetColumnInfo (ByVal TableName, ByRef arColumns)
\r
1013 If debug then DisplayMsg "Getting column info for: " & TableName
\r
1014 SplitTabName TableName,dbname,owner,table
\r
1016 Set rs = EnumColumnsADO(4,TableName)
\r
1017 if rs is Nothing Then exit function
\r
1018 If debug and rs.EOF then DisplayMsg "EOF column info"
\r
1020 if not IsEmpty(arColumns(cnt)) then set arColumns(cnt)=Nothing
\r
1021 'DisplayMsg "Loading column #" & cnt & " " & rs("TABLE_CATALOG") & "." & rs("TABLE_NAME") & "." & rs("COLUMN_NAME") & " " & rs("DATA_TYPE") & " " & hex(rs("COLUMN_FLAGS"))
\r
1022 set arColumns(cnt)=new dbColumn
\r
1023 with arColumns(cnt)
\r
1024 .ColName=rs("COLUMN_NAME")
\r
1025 .ColType=ADOColType(clng(rs("DATA_TYPE")))
\r
1026 if .ColType="INT" then
\r
1027 .ColLength=rs("NUMERIC_PRECISION")
\r
1029 .ColLength=rs("CHARACTER_MAXIMUM_LENGTH")
\r
1031 .Nullable=rs("IS_NULLABLE")
\r
1032 .Writeable=((rs("COLUMN_FLAGS") and &H000000C) <> 0)
\r
1033 .FixedLength=((rs("COLUMN_FLAGS") and &H0000010) <> 0)
\r
1041 Set rs = EnumColumnsADO(28,TableName)
\r
1042 if rs is Nothing Then exit function
\r
1045 if arColumns(i).ColName=rs("COLUMN_NAME") then
\r
1046 arColumns(i).IsPKey=true
\r
1054 if Dialect <> "Access" then exit function
\r
1056 ' check for AutoNumber columns
\r
1058 Set ADOXcat = CreateObject("ADOX.Catalog")
\r
1059 Set ADOXcat.ActiveConnection = dbMain
\r
1060 Set cols=ADOXcat.Tables(table).Columns
\r
1062 If cols(arColumns(i).ColName).Properties("Autoincrement").Value = True Then
\r
1063 'DisplayMsg arColumns(i).ColName & " is Autoincrement"
\r
1064 arColumns(i).Writeable = false
\r
1067 Set ADOXcat = Nothing
\r
1071 ' -------------------------------------------------------------
\r
1072 ' Returns a SQL create statement based on the structure of an existing table
\r
1073 ' but with a new table name substituted on the create line.
\r
1074 ' Returns an empty string if there is an error (e.g. OldTableName doesn't exist)
\r
1075 ' -------------------------------------------------------------
\r
1076 Public function GenCreateFromTable (ByVal OldTableName, ByVal NewTableName)
\r
1077 dim rsLookUp,sqltext,coltype
\r
1079 GenCreateFromTable=""
\r
1081 set rsLookUp = EnumColumns(OldTableName)
\r
1082 if rsLookUp is Nothing then exit function
\r
1083 if rsLookUp.EOF then exit function
\r
1084 Do while not rsLookUp.EOF
\r
1085 coltype=ucase(trim(rsLookUp("TYPE_NAME")))
\r
1086 if sqltext = "" then
\r
1087 sqltext="create table " & NewTableName & " (" & vbLf
\r
1089 sqltext=sqltext & "," & vbLf
\r
1091 sqltext=sqltext & " [" & trim(rsLookUp("COLUMN_NAME")) & "] " & coltype
\r
1092 if InStr(coltype,"CHAR") > 0 or InStr(coltype,"BINARY") > 0 then
\r
1093 sqltext=sqltext & "(" & rsLookUp("LENGTH") & ")"
\r
1094 elseif coltype="DECIMAL" or coltype="NUMERIC" then
\r
1095 sqltext=sqltext & "(" & rsLookUp("PRECISION") & "," & rsLookUp("SCALE") & ")"
\r
1097 if rsLookUp("NULLABLE") = 0 then
\r
1098 sqltext=sqltext & " NOT NULL"
\r
1100 sqltext=sqltext & " NULL"
\r
1104 sqltext=sqltext & vbLf & ")"
\r
1106 GenCreateFromTable=sqltext
\r
1110 ' -------------------------------------------------------------
\r
1111 ' Add a condition to a where or having clause
\r
1112 ' -------------------------------------------------------------
\r
1113 Public Sub AddCondition(ByRef WhereClause, ByVal NewCondition)
\r
1114 if IsEmpty(NewCondition) then exit sub
\r
1115 If IsEmpty(WhereClause) Then
\r
1116 WhereClause="(" & NewCondition & ")"
\r
1118 WhereClause=WhereClause & " AND (" & NewCondition & ")"
\r