% ' ---------------------------------------------------------------------- ' ' Page : dbClass3.vbs ' Description : Routines to access a SQL database using ADO ' Author : Matt Brown (dowdybrown@yahoo.com) ' Copyright (C) 2006-2011 Matt Brown ' ' Rico is licensed under the Apache License, Version 2.0 (the "License"); you may not use this ' file except in compliance with the License. You may obtain a copy of the License at ' http://www.apache.org/licenses/LICENSE-2.0 ' ' ---------------------------------------------------------------------- '******************************************************************************************************** ' Parse SQL a statement '******************************************************************************************************** class sqlParse public arSelList,arSelListAs,FromClause,WhereClause,arGroupBy,HavingClause,arOrderBy,IsDistinct Public function ToArray() ToArray=Array(arSelList,arSelListAs,FromClause,WhereClause,arGroupBy,HavingClause,arOrderBy,IsDistinct) end function Public Sub LoadArray(a) arSelList=a(0) arSelListAs=a(1) FromClause=a(2) WhereClause=a(3) arGroupBy=a(4) HavingClause=a(5) arOrderBy=a(6) IsDistinct=a(7) end Sub ' ------------------------------------------------------------- ' Rebuilds a SQL select statement that was parsed by ParseSelect ' ------------------------------------------------------------- Private function Unparse(arSkipCols) dim sqltext sqltext="SELECT " if IsDistinct then sqltext=sqltext & "DISTINCT " sqltext=sqltext & UnparseColumnListSkip(arSkipCols) & " FROM " & FromClause if not IsEmpty(WhereClause) then sqltext=sqltext & " WHERE " & WhereClause if IsArray(arGroupBy) then if UBound(arGroupBy)>=0 then sqltext=sqltext & " GROUP BY " & join(arGroupBy,",") end if if not IsEmpty(HavingClause) then sqltext=sqltext & " HAVING " & HavingClause if IsArray(arOrderBy) then if UBound(arOrderBy)>=0 then sqltext=sqltext & " ORDER BY " & join(arOrderBy,",") end If Unparse=sqltext end Function Public function UnparseSelect() UnparseSelect=Unparse(array()) end Function Public function UnparseSelectSkip(arSkipCols) UnparseSelectSkip=Unparse(arSkipCols) end Function Public function UnparseSelectDistinct() IsDistinct=true UnparseSelectDistinct=Unparse(array()) end Function Public function UnparseDistinctColumn(colnum) dim sqltext sqltext="SELECT DISTINCT " & arSelList(colnum) & " FROM " & FromClause if not IsEmpty(WhereClause) then sqltext=sqltext & " WHERE " & WhereClause sqltext=sqltext & " ORDER BY " & arSelList(colnum) UnparseDistinctColumn=sqltext end Function Public function UnparseColumn(ByVal i) dim s s=arSelList(i) if not IsEmpty(arSelListAs(i)) then s=s & " AS " & arSelListAs(i) UnparseColumn=s end Function Public function UnparseColumnList() UnparseColumnList=UnparseColumnListSkip(array()) end Function Public function UnparseColumnListSkip(arSkipCols) dim sqltext,i,SkipIdx,skip SkipIdx=0 for i=0 to ubound(arSelList) skip=false if SkipIdx <= ubound(arSkipCols) then skip=CBool(arSkipCols(SkipIdx)=CStr(i)) if skip then SkipIdx=SkipIdx+1 end if if not skip then if not IsEmpty(sqltext) then sqltext=sqltext & "," sqltext=sqltext & arSelList(i) & " AS rico_col" & i end if next UnparseColumnListSkip=sqltext end Function Public Sub DebugPrint() dim i response.write "
Parse Result:" response.write "
DISTINCT | " response.write " |
COLUMNS: |
|
FROM: | " & FromClause if not IsEmpty(WhereClause) then response.write " |
WHERE: | " & WhereClause if IsArray(arGroupBy) then if UBound(arGroupBy)>=0 then response.write " |
GROUP BY: | " & join(arGroupBy," ") end if if not IsEmpty(HavingClause) then response.write " |
HAVING: | " & HavingClause if IsArray(arOrderBy) then if UBound(arOrderBy)>=0 then response.write " |
ORDER BY: | " & join(arOrderBy," ") end If response.write " |
ParseSelect: " & sqltext & "
" l=len(sqltext) parencnt=0 inquote=false i=1 curfield="" while i" & clause & ": " & server.htmlencode(curfield) & "
" select case clause case "SELECT": SetParseField arSelList,curfield Push arSelListAs,Empty case "AS": arSelListAs(ubound(arSelList))=curfield curfield="" clause="SELECT" case "GROUP BY": SetParseField arGroupBy,curfield case "ORDER BY": SetParseField arOrderBy,curfield case else: curfield=curfield & ch end select elseif ch=" " then j=InStr(i+1,sqltext," ") if j<1 then curfield=curfield & ch else if ucase(mid(sqltext,j+1,3))="BY " then j=j+3 nexttoken=ucase(mid(sqltext,i+1,j-i-1)) 'wscript.echo "'" & nexttoken & "'" 'response.write "" & clause & " : " & nexttoken & " : " & server.htmlencode(curfield) & "
" select case nexttoken case "SELECT","INTO","FROM","WHERE","GROUP BY","HAVING","ORDER BY": select case clause case "SELECT": AddColumn curfield,Empty curfield="" case "AS": arSelListAs(ubound(arSelList))=curfield curfield="" case "FROM": SetParseField FromClause,curfield case "WHERE": SetParseField WhereClause,curfield case "GROUP BY": SetParseField arGroupBy,curfield case "HAVING": SetParseField HavingClause,curfield case "ORDER BY": SetParseField arOrderBy,curfield end select clause=nexttoken i=j-1 case "AS": if clause="SELECT" then AddColumn curfield,Empty curfield="" clause=nexttoken i=j elseif curfield<>"" then curfield=curfield & ch end if case "DISTINCT": if clause="SELECT" then IsDistinct=true curfield="" i=j elseif curfield<>"" then curfield=curfield & ch end if case else: if curfield<>"" then curfield=curfield & ch end select end if else curfield=curfield & ch end if i=i+1 wend ParseSelect=true end function Private sub Push(f, ByVal newvalue) ReDim Preserve f(ubound(f)+1) f(ubound(f))=newvalue end sub Private sub SetParseField(f, ByRef newvalue) if IsArray(f) then Push f,newvalue else f=newvalue end if newvalue="" end sub ' ------------------------------------------------------------- ' Add column to select list ' ------------------------------------------------------------- Public Sub AddColumn(ByVal ColumnSql, ByVal ColumnName) Push arSelList,ColumnSql Push arSelListAs,ColumnName end sub Public Function LastColumn() LastColumn=arSelList(ubound(arSelList)) end function ' ------------------------------------------------------------- ' Add a join to the from clause ' ------------------------------------------------------------- Public Sub AddJoin(ByVal JoinClause) if InStr(FromClause," join ")>0 then FromClause="(" & FromClause & ")" ' required by Access FromClause=FromClause & " " & JoinClause end sub Private Sub SplitSortSpec(ByVal sortspec, ByRef sortcol, ByRef sortdir) sortspec=ucase(sortspec) if right(sortspec,3)="ASC" then sortcol=trim(left(sortspec,len(sortspec)-3)) sortdir="ASC" elseif right(sortspec,4)="DESC" then sortcol=trim(left(sortspec,len(sortspec)-4)) sortdir="DESC" else sortcol=trim(sortspec) sortdir="" end if End Sub Private Function FindSortColumn(ByVal sortspec) dim i, findcol, finddir, sortcol, sortdir FindSortColumn=-1 SplitSortSpec sortspec, findcol, finddir for i=0 to ubound(arOrderBy) SplitSortSpec arOrderBy(i), sortcol, sortdir if sortcol=findcol then FindSortColumn=i exit for end if next End Function ' ------------------------------------------------------------- ' Add sort criteria to the beginning of the order by clause ' ------------------------------------------------------------- Public Sub AddSort(ByVal NewSort) dim i, colidx colidx=FindSortColumn(NewSort) if colidx>=0 then for i=colidx to 1 step -1 arOrderBy(i)=arOrderBy(i-1) next arOrderBy(0)=NewSort else ReDim Preserve arOrderBy(ubound(arOrderBy)+1) for i=ubound(arOrderBy) to 1 step -1 arOrderBy(i)=arOrderBy(i-1) next arOrderBy(0)=NewSort end if end sub ' ------------------------------------------------------------- ' Append sort criteria to the order by clause ' ------------------------------------------------------------- Public Sub AppendSort(ByVal NewSort) Push arOrderBy,NewSort end sub ' ------------------------------------------------------------- ' Add a condition to the where clause ' ------------------------------------------------------------- Public Sub AddWhereCondition(ByVal NewCondition) AddCondition WhereClause,NewCondition end sub ' ------------------------------------------------------------- ' Add a condition to the having clause ' ------------------------------------------------------------- Public Sub AddHavingCondition(ByVal NewCondition) AddCondition HavingClause,NewCondition end sub Private Sub AddCondition(ByRef Clause, ByVal NewCondition) if IsEmpty(NewCondition) then exit sub If IsEmpty(Clause) Then Clause="(" & NewCondition & ")" Else Clause=Clause & " AND (" & NewCondition & ")" End If End Sub end class '******************************************************************************************************** ' created by dbClass.GetColumnInfo() '******************************************************************************************************** class dbColumn Public ColName,Nullable,ColType,ColLength,Writeable,IsPKey,FixedLength end class '******************************************************************************************************** ' Manage a database connection '******************************************************************************************************** class dbClass Public SqlSvr,debug,ConnTimeout,CmdTimeout,LockTimeout,Provider,OdbcDriver Public ErrMsgFmt ' empty=errors not shown, otherwise "HTML" or "MULTILINE" or "1LINE" Public DisplayErrors ' true/false Public LastErrorMsg,Dialect Private dbMain,DisplayFunc,dbDefault ' ------------------------------------------------------------- ' Class Constructor ' ------------------------------------------------------------- Private Sub Class_Initialize ' Setup Initialize event. dim tw,tr SqlSvr = "localhost" Use_TSQL debug=false ConnTimeout=30 ' seconds LockTimeout=5000 ' milliseconds DisplayErrors=true on error resume next ' if running with option explicit, then the next lines cause an error tw=TypeName(wscript) tr=TypeName(response) if tw<>"Empty" then if IsObject(wscript) then ErrMsgFmt="1LINE" CmdTimeout = 3600 ' 60 minutes for wsh/cscript DisplayFunc="wscript.echo " end if elseif tr<>"Empty" then if IsObject(response) then ErrMsgFmt="HTML" CmdTimeout = 120 ' 2 minutes for asp pages DisplayFunc="response.write " end if else ErrMsgFmt="MULTILINE" CmdTimeout = 30 DisplayFunc="msgbox " End If 'DisplayMsg "Message format set to " & ErrMsgFmt End Sub Public function Connection() set Connection=dbMain end function Public Sub Use_TSQL() Dialect="TSQL" Provider="SQLOLEDB" End Sub Public Sub Use_Access(FileName) Dialect="Access" Provider="Microsoft.Jet.OLEDB.4.0" SqlSvr=FileName End Sub Public Sub Use_MySQL() Dialect="MySQL" OdbcDriver="{MySQL ODBC 3.51 Driver}" End Sub Public Sub Use_Oracle(SIM) Dialect="Oracle" 'Provider="MSDAORA" Provider="OraOLEDB.Oracle" SqlSvr=SIM End Sub Public function CurrentTime() select case Dialect case "TSQL","DB2": CurrentTime="CURRENT_TIMESTAMP" case "Access": CurrentTime="Now()" case else: CurrentTime="LOCALTIMESTAMP" end select end function Public function Convert2Char(s) select case Dialect case "TSQL" : Convert2Char="cast(" & s & " as varchar)" case "Access": Convert2Char="CStr(" & s & ")" case "DB2" : Convert2Char="CHAR(" & s & ")" case "MySQL" : Convert2Char="{fn CONVERT(" & s & ",CHAR)}" ' use ODBC's convert function case "Oracle": Convert2Char="cast(" & s & " as varchar2(20))" case else: Convert2Char=s ' implicit conversion end select end function Public function SqlDay(s) select case Dialect case "Oracle": SqlDay="to_char(" & s & ",'DD')" case "MySQL": SqlDay="dayofmonth(" & s & ")" case else: SqlDay="day(" & s & ")" end select end function Public function SqlMonth(s) select case Dialect case "Oracle": SqlMonth="to_char(" & s & ",'MM')" case else: SqlMonth="month(" & s & ")" end select end function Public function SqlYear(s) select case Dialect case "Oracle": SqlYear="to_char(" & s & ",'YYYY')" case else: SqlYear="year(" & s & ")" end select end function Public function Wildcard() Wildcard="%" end function Public function addQuotes(s) select case Dialect case "Access": if IsDate(s) then addQuotes="#" & s & "#" else addQuotes="""" & replace(s,"""","""""") & """" end if case "MySQL": addQuotes="'" & replace(replace(s,"\","\\"),"'","\'") & "'" case else: addQuotes="'" & replace(s,"'","''") & "'" end select end function Public function Concat(arStrings,addQuotes) dim i if addQuotes then for i=0 to ubound(arStrings) arStrings(i)=addQuotes(arStrings(i)) next end if select case Dialect case "TSQL": Concat=join(arStrings,"+") case "Access": Concat=join(arStrings," & ") case "MySQL": Concat="concat(" & join(arStrings,",") & ")" case else: Concat=join(arStrings," || ") end select end function ' ------------------------------------------------------------- ' Class Destructor ' ------------------------------------------------------------- Private Sub Class_Terminate ' Setup Terminate event. dbClose End Sub ' ------------------------------------------------------------- ' If the database is down, then an explanation can be placed here ' ------------------------------------------------------------- Public function MaintenanceMsg() MaintenanceMsg="" end function Public function DefaultDB() DefaultDB=dbDefault end function ' ------------------------------------------------------------- ' Attempts to connect to the database using Windows security. ' Returns true on success. ' For use with MS SQL Server ' ------------------------------------------------------------- Public function WinLogon(ByVal DefDB) dim connstr dbDefault=DefDB if IsEmpty(OdbcDriver) Then connstr="Provider=" & Provider & ";Data Source=" & SqlSvr & ";Integrated Security=SSPI;" if DefDB<>"" then connstr=connstr & "Initial Catalog=" & DefDB & ";" else connstr="DRIVER=" & OdbcDriver & ";SERVER=" & SqlSvr & ";Trusted_Connection=Yes;" if DefDB<>"" then connstr=connstr & "DATABASE=" & DefDB & ";" end if WinLogon=dbConnect(connstr) end function ' ------------------------------------------------------------- ' Attempts to connect to the database using sql security model. ' Returns true on success. ' ------------------------------------------------------------- Public function SqlLogon(ByVal DefDB, ByVal userid, ByVal pw) dim connstr dbDefault=DefDB if IsEmpty(OdbcDriver) then connstr="Provider=" & Provider & ";Data Source=" & SqlSvr & ";" if userid<>"" then connstr=connstr & "User Id=" & userid & ";Password=" & pw & ";" if DefDB<>"" then connstr=connstr & "Initial Catalog=" & DefDB & ";" else connstr="DRIVER=" & OdbcDriver & ";SERVER=" & SqlSvr & ";" if userid<>"" then connstr=connstr & "USER=" & userid & ";PASSWORD=" & pw & ";" if DefDB<>"" then connstr=connstr & "DATABASE=" & DefDB & ";" end if SqlLogon=dbConnect(connstr) end function ' ------------------------------------------------------------- ' Attempts to connect to the Database. Returns true on success. ' ------------------------------------------------------------- Public function dbConnect(ByVal ConnStr) if MaintenanceMsg<>"" then HandleError MaintenanceMsg exit function end if On Error Resume Next dbConnect=false if not IsObject(dbMain) then set dbMain = CreateObject("ADODB.Connection") if CheckForError("creating ADODB object") then exit function end if if debug then DisplayMsg "Connect String: " & ConnStr dbMain.ConnectionTimeout = ConnTimeout dbMain.Open ConnStr if CheckForError("opening connection: " & ConnStr) then exit function dbMain.CommandTimeout = CmdTimeout if Dialect="TSQL" then RunActionQuery "SET LOCK_TIMEOUT " & LockTimeout dbConnect=true end function ' ------------------------------------------------------------- ' Close database connection ' ------------------------------------------------------------- Public sub dbClose if IsObject(dbMain) then if dbMain.state <> 0 then dbMain.Close set dbMain = Nothing ' releases memory, but still an object dbMain = Empty ' cause IsObject to return false end if End sub ' ------------------------------------------------------------- ' return true if database connection is open ' ------------------------------------------------------------- Public Function dbIsOpen dbIsOpen=false if IsObject(dbMain) then if dbMain.state <> 0 then dbIsOpen=true end if End Function ' ------------------------------------------------------------- ' Return a string containing an error message ' String format is based on ErrMsgFmt ' ------------------------------------------------------------- Private Function FormatErrorMsg(ByVal ContextMsg) select case ErrMsgFmt case "HTML": FormatErrorMsg = "Error # " & Hex(err.number) & " was generated by " & err.Source & "
" & FixHtmlStr(err.Description) & "
Operation that caused the error:
" & FixHtmlStr(ContextMsg) & "
" & Server.HTMLEncode(replace(msg,vbLf,"
"))
else
msg=replace(msg,vbLf," ")
end if
execute DisplayFunc & """" & replace(msg,"""","""""") & """"
End If
end sub
Private sub HandleError(msg)
LastErrorMsg=msg
if DisplayErrors then DisplayMsg LastErrorMsg
End sub
' -------------------------------------------------------------
' Checks if an error has occurred, and if so, displays a message & returns true
' -------------------------------------------------------------
Private function CheckForError(msg)
CheckForError=false
If err.number = 0 Then exit function
CheckForError=true
if IsEmpty(ErrMsgFmt) Then exit function
HandleError FormatErrorMsg(msg)
End function
' -------------------------------------------------------------
' Runs a query and moves to the first record.
' Use only for queries that return records (no updates or deletes).
' If the query generated an error then Nothing is returned, otherwise it returns a new recordset object.
' -------------------------------------------------------------
Public Function RunQuery(sqltext)
Dim rsLookUp
On Error Resume Next
Set rsLookUp = dbMain.Execute(sqltext)
If CheckForError(sqltext) Then
Set RunQuery = Nothing
Exit Function
End If
If debug then DisplayMsg sqltext
If Not rsLookUp.EOF Then rsLookUp.MoveFirst
Set RunQuery = rsLookUp
End Function
' -------------------------------------------------------------
' Runs a parameterized query (put ? in sqltext to indicate where parameters should be inserted)
' Use only for queries that return records (no updates or deletes).
' If the query generated an error then Nothing is returned, otherwise it returns a new recordset object.
' -------------------------------------------------------------
Public Function RunParamQuery(sqltext, arParams)
Dim rsLookUp,cmd,RecordsAffected
On Error Resume Next
set objCmd = CreateObject("ADODB.Command")
Set objCmd.ActiveConnection = dbMain
objCmd.CommandText = sqltext
objCmd.CommandType = 1 ' adCmdText
Set rsLookUp = objCmd.Execute(RecordsAffected,arParams)
If CheckForError(sqltext) Then
Set RunParamQuery = Nothing
Exit Function
End If
If debug then DisplayMsg sqltext
set objCmd = Nothing
Set RunParamQuery = rsLookUp
End Function
' -------------------------------------------------------------
' Safely close a recordset
' -------------------------------------------------------------
Public Sub rsClose(ByRef rsLookUp)
If IsObject(rsLookUp) Then
If Not (rsLookUp Is Nothing) Then
If rsLookUp.State <> 0 Then ' adStateClosed=0
rsLookUp.Close
End If
Set rsLookUp = Nothing
End If
End If
End Sub
' -------------------------------------------------------------
' Runs a query and returns results from the first record in dicData.
' Returns true if dicData is modified (ie. a record exists).
' If the query generates an error then dicData is left unchanged
' dicData can be a dictionary object, an array, or a scalar
' If dicData is a scalar, it will be assigned the value of the first field in the first row.
' -------------------------------------------------------------
Public Function SingleRecordQuery(ByVal sqltext, ByRef dicData)
Dim rsMain, i
SingleRecordQuery = False
Set rsMain = RunQuery(sqltext)
If rsMain Is Nothing Then Exit Function
If Not rsMain.EOF Then
If IsObject(dicData) Then
For i = 0 To rsMain.Fields.Count - 1
dicData(rsMain.Fields(i).name) = rsMain.Fields(i).Value
Next
ElseIf IsArray(dicData) Then
For i = 0 To rsMain.Fields.Count - 1
dicData(i) = rsMain.Fields(i).Value
Next
Else
dicData = rsMain.Fields(0).Value
End If
SingleRecordQuery = True
End If
rsClose rsMain
End Function
' -------------------------------------------------------------
' Runs a query where no result set is expected (updates, deletes, etc)
' - returns the number of records affected by the action query
' -------------------------------------------------------------
Public Function RunActionQuery(ByVal sqltext)
Dim RecordsAffected, spflag
On Error Resume Next
RunActionQuery = 0
spflag = (UCase(Left(sqltext, 4)) = "EXEC")
If spflag Then dbMain.Execute "SET NOCOUNT ON"
dbMain.Execute sqltext, RecordsAffected, &H80 ' adExecuteNoRecords (hard coded so that adovbs.inc is not required)
If CheckForError(sqltext) Then
Exit Function
ElseIf debug then
DisplayMsg sqltext
if not IsEmpty(RecordsAffected) and not IsNull(RecordsAffected) then
DisplayMsg RecordsAffected & " records affected"
end if
End If
RunActionQuery = RecordsAffected
End Function
' -------------------------------------------------------------
' Runs a query where no result set is expected (updates, deletes, etc)
' - if an error occurs, then the message is returned in errmsg
' -------------------------------------------------------------
Public function RunActionQueryReturnMsg (ByVal sqltext, ByRef errmsg)
dim tmpDisplayErrors
tmpDisplayErrors=DisplayErrors
DisplayErrors=false
LastErrorMsg=Empty
RunActionQueryReturnMsg=RunActionQuery(sqltext)
if not IsEmpty(LastErrorMsg) then errmsg=LastErrorMsg
DisplayErrors=tmpDisplayErrors
end function
' -------------------------------------------------------------
' Takes a sql create (table or view) statement and performs:
' 1) a conditional drop (if it already exists)
' 2) the create
' 3) grants select access to public (if not a temp table)
'
' for views, all actions must occur on the default database for the connection
' -------------------------------------------------------------
Public sub DropCreate (sqlcreate)
dim sqltext,shortname,parsed,arName,db
parsed=split(sqlcreate," ",4)
arName=split(parsed(2),".")
shortname=arName(ubound(arName))
if ubound(arName)=2 then db=arName(0) else db=dbDefault
sqltext="IF EXISTS (SELECT * from " & db & ".dbo.sysobjects WHERE name='" & shortname & "') DROP " & parsed(1) & " " & parsed(2)
RunActionQuery sqltext
RunActionQuery sqlcreate
if left(shortname,1) <> "#" and db=dbDefault then
sqltext="GRANT SELECT ON " & parsed(2) & " TO public"
RunActionQuery sqltext
end if
end sub
' -------------------------------------------------------------
' Returns a recordset that will enumerate the columns in a table or view
' objname may be a fully qualified object name
' -------------------------------------------------------------
Public function EnumColumns (ByVal objname)
select case Dialect
case "TSQL": set EnumColumns=RunQuery("exec sp_columns " & TabName2SpParms(objname))
case "Access": set EnumColumns=empty
case "MySQL": set EnumColumns=RunQuery("show full columns from " & objname)
case else: set EnumColumns=RunQuery("describe " & objname)
end select
end function
' -------------------------------------------------------------
' Convert the numeric value returned by DB to Enum, so
' that at least the user could have a guess of what it is.
' -------------------------------------------------------------
Public Function ConvType(ByVal TypeVal)
Select Case TypeVal
Case 20 ConvType = "adBigInt"
Case 128 ConvType = "adBinary"
Case 11 ConvType = "adBoolean"
Case 8 ConvType = "adBSTR" ' i.e. null terminated string
Case 129 ConvType = "adChar"
Case 6 ConvType = "adCurrency"
Case 7 ConvType = "adDate"
Case 133 ConvType = "adDBDate"
Case 134 ConvType = "adDBTime"
Case 135 ConvType = "adDBTimeStamp"
Case 14 ConvType = "adDecimal"
Case 5 ConvType = "adDouble"
Case 0 ConvType = "adEmpty"
Case 10 ConvType = "adError"
Case 72 ConvType = "adGUID"
Case 9 ConvType = "adIDispatch"
Case 3 ConvType = "adInteger"
Case 13 ConvType = "adIUnknown"
Case 205 ConvType = "adLongVarBinary"
Case 201 ConvType = "adLongVarChar"
Case 203 ConvType = "adLongVarWChar"
Case 131 ConvType = "adNumeric"
Case 4 ConvType = "adSingle"
Case 2 ConvType = "adSmallInt"
Case 16 ConvType = "adTinyInt"
Case 21 ConvType = "adUnsignedBigInt"
Case 19 ConvType = "adUnsignedInt"
Case 18 ConvType = "adUnsignedSmallInt"
Case 17 ConvType = "adUnsignedTinyInt"
Case 132 ConvType = "adUserDefined"
Case 204 ConvType = "adVarBinary"
Case 200 ConvType = "adVarChar"
Case 12 ConvType = "adVariant"
Case 202 ConvType = "adVarWChar"
Case 130 ConvType = "adWChar"
End Select
End Function
' -------------------------------------------------------------
' Refresh View - in case the tables on which the view is based have changed
' -------------------------------------------------------------
Public sub RefreshView (ByVal viewname)
dim sqltext,rsLookUp
sqltext="SELECT * FROM " & dbDefault & ".dbo.sysobjects o " & vbLf & _
"WHERE (o.xtype='V') AND (o.name='" & viewname & "')"
set rsLookUp = RunQuery(sqltext)
if rsLookUp.EOF then
rsClose rsLookUp
else
rsClose rsLookUp
sqltext="sp_helptext '" & viewname & "'"
set rsLookUp = RunQuery(sqltext)
sqltext=""
Do while not rsLookUp.EOF
sqltext=sqltext & rsLookUp("Text")
rsLookUp.movenext
Loop
rsClose rsLookUp
sqltext=replace(sqltext,"CREATE VIEW ","ALTER VIEW ",1,-1,1)
RunActionQuery sqltext
end if
end sub
' -------------------------------------------------------------
' Split a fully or partially qualified table name into
' its component parts (db,owner,table)
' -------------------------------------------------------------
Public sub SplitTabName (ByVal objname, ByRef dbname, ByRef owner, ByRef table)
dim arNames,last
arNames=split(objname,".")
last=ubound(arNames)
table=arNames(last)
if Dialect="Access" or Dialect="Oracle" then
owner=empty
dbname=empty
table=ucase(table)
exit sub
end if
if last>0 then
owner=arNames(last-1)
else
owner="dbo"
end if
if last>1 then
dbname=arNames(last-2)
else
dbname=dbDefault
end if
end sub
' -------------------------------------------------------------
' Converts objname (db.owner.table) to format used by
' stored procedures ('table','owner','db')
' -------------------------------------------------------------
Public function TabName2SpParms (ByVal objname)
dim table,owner,dbname
SplitTabName objname,dbname,owner,table
TabName2SpParms="'" & table & "','" & owner & "','" & dbname & "'"
end function
' -------------------------------------------------------------
' Safely add a column to a table
' -------------------------------------------------------------
Public sub AddColumnIfMissing(TableName,ColumnName,ColumnType)
dim sqltext,db,ShortName,arTableName
db=dbDefault
arTableName=split(TableName,".")
ShortName=arTableName(ubound(arTableName)) ' the last element is the unqualified table name
if ubound(arTableName)=2 then db=arTableName(0) ' if TableName was a fully qualified name, then use the db name that came with it
sqltext="IF NOT EXISTS (SELECT c.name FROM " & db & ".dbo.syscolumns c, " & db & ".dbo.sysobjects o " & vbLf & _
"WHERE c.id = o.id AND (o.xtype='U') AND (o.name='" & ShortName & "') AND (c.name='" & ColumnName & "')) " & vbLf & _
"ALTER TABLE " & TableName & " ADD " & ColumnName & " " & ColumnType
RunActionQuery sqltext
end sub
Private function ADOColType(typenum)
select case typenum
case 2,3,16,17,18,19,20,21,139: ADOColType="INT"
case 7,133,134,135: ADOColType="DATETIME"
case 129,130: ADOColType="CHAR"
case 8,200,202: ADOColType="VARCHAR"
case 201,203: ADOColType="TEXT"
case 4,5,6,14: ADOColType="FLOAT"
case 11: ADOColType="BOOLEAN"
case else: ADOColType="???" & typenum
end select
end function
' -------------------------------------------------------------
' Returns a recordset that will enumerate the columns in a table or view
' objname may be a fully qualified object name
' querytype: 4=adSchemaColumns, 27=adSchemaForeignKeys, 28=adSchemaPrimaryKeys
' -------------------------------------------------------------
Public function EnumColumnsADO (ByVal querytype, ByVal objname)
dim table,owner,dbname,reval
on error resume next
SplitTabName objname,dbname,owner,table
If debug then DisplayMsg "Getting ADO column info for: " & querytype & ", " & objname
Set reval = dbMain.OpenSchema (querytype, Array(dbname, owner, table))
if CheckForError("OpenSchema: " & querytype & "," & dbname & "," & owner & "," & table) then
Set reval = Nothing
end if
Set EnumColumnsADO = reval
end function
'********************************************************************************************************
' Returns a comma-separated list of column names that make up the primary key
' Returns empty if no primary key has been defined
'********************************************************************************************************
Public function PrimaryKey(TableName)
Dim rs,colnames
If debug then DisplayMsg "Getting primary key for: " & TableName
Set rs = EnumColumnsADO(28,TableName)
if rs is Nothing Then exit function
While Not rs.EOF
if IsEmpty(colnames) then colnames=rs("COLUMN_NAME") else colnames=colnames & "," & rs("COLUMN_NAME")
rs.MoveNext
Wend
rs.Close
PrimaryKey=colnames
end function
' returns number of columns, or -1 if there was en error
Public function GetColumnInfo (ByVal TableName, ByRef arColumns)
dim rs,cnt,i
GetColumnInfo=-1
If debug then DisplayMsg "Getting column info for: " & TableName
SplitTabName TableName,dbname,owner,table
cnt=0
Set rs = EnumColumnsADO(4,TableName)
if rs is Nothing Then exit function
If debug and rs.EOF then DisplayMsg "EOF column info"
While Not rs.EOF
if not IsEmpty(arColumns(cnt)) then set arColumns(cnt)=Nothing
'DisplayMsg "Loading column #" & cnt & " " & rs("TABLE_CATALOG") & "." & rs("TABLE_NAME") & "." & rs("COLUMN_NAME") & " " & rs("DATA_TYPE") & " " & hex(rs("COLUMN_FLAGS"))
set arColumns(cnt)=new dbColumn
with arColumns(cnt)
.ColName=rs("COLUMN_NAME")
.ColType=ADOColType(clng(rs("DATA_TYPE")))
if .ColType="INT" then
.ColLength=rs("NUMERIC_PRECISION")
else
.ColLength=rs("CHARACTER_MAXIMUM_LENGTH")
end if
.Nullable=rs("IS_NULLABLE")
.Writeable=((rs("COLUMN_FLAGS") and &H000000C) <> 0)
.FixedLength=((rs("COLUMN_FLAGS") and &H0000010) <> 0)
.IsPKey=false
end with
cnt=cnt+1
rs.MoveNext
Wend
rs.Close
Set rs = EnumColumnsADO(28,TableName)
if rs is Nothing Then exit function
While Not rs.EOF
for i=0 to cnt-1
if arColumns(i).ColName=rs("COLUMN_NAME") then
arColumns(i).IsPKey=true
exit for
end if
next
rs.MoveNext
Wend
rs.Close
GetColumnInfo=cnt
if Dialect <> "Access" then exit function
' check for AutoNumber columns
dim ADOXcat,cols
Set ADOXcat = CreateObject("ADOX.Catalog")
Set ADOXcat.ActiveConnection = dbMain
Set cols=ADOXcat.Tables(table).Columns
for i=0 to cnt-1
If cols(arColumns(i).ColName).Properties("Autoincrement").Value = True Then
'DisplayMsg arColumns(i).ColName & " is Autoincrement"
arColumns(i).Writeable = false
End If
next
Set ADOXcat = Nothing
end function
' -------------------------------------------------------------
' Returns a SQL create statement based on the structure of an existing table
' but with a new table name substituted on the create line.
' Returns an empty string if there is an error (e.g. OldTableName doesn't exist)
' -------------------------------------------------------------
Public function GenCreateFromTable (ByVal OldTableName, ByVal NewTableName)
dim rsLookUp,sqltext,coltype
GenCreateFromTable=""
sqltext=""
set rsLookUp = EnumColumns(OldTableName)
if rsLookUp is Nothing then exit function
if rsLookUp.EOF then exit function
Do while not rsLookUp.EOF
coltype=ucase(trim(rsLookUp("TYPE_NAME")))
if sqltext = "" then
sqltext="create table " & NewTableName & " (" & vbLf
else
sqltext=sqltext & "," & vbLf
end if
sqltext=sqltext & " [" & trim(rsLookUp("COLUMN_NAME")) & "] " & coltype
if InStr(coltype,"CHAR") > 0 or InStr(coltype,"BINARY") > 0 then
sqltext=sqltext & "(" & rsLookUp("LENGTH") & ")"
elseif coltype="DECIMAL" or coltype="NUMERIC" then
sqltext=sqltext & "(" & rsLookUp("PRECISION") & "," & rsLookUp("SCALE") & ")"
end if
if rsLookUp("NULLABLE") = 0 then
sqltext=sqltext & " NOT NULL"
else
sqltext=sqltext & " NULL"
end if
rsLookUp.movenext
Loop
sqltext=sqltext & vbLf & ")"
rsClose rsLookUp
GenCreateFromTable=sqltext
end function
' -------------------------------------------------------------
' Add a condition to a where or having clause
' -------------------------------------------------------------
Public Sub AddCondition(ByRef WhereClause, ByVal NewCondition)
if IsEmpty(NewCondition) then exit sub
If IsEmpty(WhereClause) Then
WhereClause="(" & NewCondition & ")"
Else
WhereClause=WhereClause & " AND (" & NewCondition & ")"
End If
End Sub
end class
%>