git.infodrom.org Git - infodrom/rico3/blob - plugins/asp/dbClass3.vbs

   1 <%\r
   2 \r
   3 ' ----------------------------------------------------------------------\r
   4 '\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
   9 '\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
  13 '\r
  14 ' ----------------------------------------------------------------------\r
  15 \r
  16 '********************************************************************************************************\r
  17 ' Parse SQL a statement\r
  18 '********************************************************************************************************\r
  19 class sqlParse\r
  20 \r
  21 public arSelList,arSelListAs,FromClause,WhereClause,arGroupBy,HavingClause,arOrderBy,IsDistinct\r
  22 \r
  23 \r
  24 Public function ToArray()\r
  25   ToArray=Array(arSelList,arSelListAs,FromClause,WhereClause,arGroupBy,HavingClause,arOrderBy,IsDistinct)\r
  26 end function\r
  27 \r
  28 Public Sub LoadArray(a)\r
  29   arSelList=a(0)\r
  30   arSelListAs=a(1)\r
  31   FromClause=a(2)\r
  32   WhereClause=a(3)\r
  33   arGroupBy=a(4)\r
  34   HavingClause=a(5)\r
  35   arOrderBy=a(6)\r
  36   IsDistinct=a(7)\r
  37 end Sub\r
  38 \r
  39 ' -------------------------------------------------------------\r
  40 ' Rebuilds a SQL select statement that was parsed by ParseSelect\r
  41 ' -------------------------------------------------------------\r
  42 Private function Unparse(arSkipCols)\r
  43   dim sqltext\r
  44   sqltext="SELECT "\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
  50   end if\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
  54   end If\r
  55   Unparse=sqltext\r
  56 end Function\r
  57 \r
  58 \r
  59 Public function UnparseSelect()\r
  60   UnparseSelect=Unparse(array())\r
  61 end Function\r
  62 \r
  63 \r
  64 Public function UnparseSelectSkip(arSkipCols)\r
  65   UnparseSelectSkip=Unparse(arSkipCols)\r
  66 end Function\r
  67 \r
  68 \r
  69 Public function UnparseSelectDistinct()\r
  70   IsDistinct=true\r
  71   UnparseSelectDistinct=Unparse(array())\r
  72 end Function\r
  73 \r
  74 \r
  75 Public function UnparseDistinctColumn(colnum)\r
  76   dim sqltext\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
  81 end Function\r
  82 \r
  83 \r
  84 Public function UnparseColumn(ByVal i)\r
  85   dim s\r
  86   s=arSelList(i)\r
  87   if not IsEmpty(arSelListAs(i)) then s=s & " AS " & arSelListAs(i)\r
  88   UnparseColumn=s\r
  89 end Function\r
  90 \r
  91 \r
  92 Public function UnparseColumnList()\r
  93   UnparseColumnList=UnparseColumnListSkip(array())\r
  94 end Function\r
  95 \r
  96 \r
  97 Public function UnparseColumnListSkip(arSkipCols)\r
  98   dim sqltext,i,SkipIdx,skip\r
  99   SkipIdx=0\r
 100   for i=0 to ubound(arSelList)\r
 101     skip=false\r
 102     if SkipIdx <= ubound(arSkipCols) then\r
 103       skip=CBool(arSkipCols(SkipIdx)=CStr(i))\r
 104       if skip then SkipIdx=SkipIdx+1\r
 105     end if\r
 106     if not skip then\r
 107       if not IsEmpty(sqltext) then sqltext=sqltext & ","\r
 108       sqltext=sqltext & arSelList(i) & " AS rico_col" & i\r
 109     end if\r
 110   next\r
 111   UnparseColumnListSkip=sqltext\r
 112 end Function\r
 113 \r
 114 \r
 115 Public Sub DebugPrint()\r
 116   dim i\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>&nbsp;"\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
 123   next\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
 128   end if\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
 132   end If\r
 133   response.write "</table>"\r
 134 End Sub\r
 135 \r
 136 \r
 137 Public sub Init(ub)\r
 138   redim arSelList(ub),arSelListAs(ub),arGroupBy(-1),arOrderBy(-1)\r
 139   FromClause=empty\r
 140   WhereClause=empty\r
 141   HavingClause=empty\r
 142   IsDistinct=false\r
 143 end sub\r
 144 \r
 145 \r
 146 ' -------------------------------------------------------------\r
 147 ' Parse a SQL select statement into its major components\r
 148 ' Does not handle:\r
 149 ' 1) union queries\r
 150 ' 2) select into\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
 156   Init(-1)\r
 157   ParseSelect=false\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
 161   l=len(sqltext)\r
 162   parencnt=0\r
 163   inquote=false\r
 164   i=1\r
 165   curfield=""\r
 166   while i<l\r
 167     ch=mid(sqltext,i,1)\r
 168     if inquote then\r
 169       if ch=endquote then\r
 170         if endquote="'" and mid(sqltext,i,2)="''" then\r
 171           curfield=curfield & "'"\r
 172           i=i+1\r
 173         else\r
 174           inquote=false\r
 175         end if\r
 176       end if\r
 177       curfield=curfield & ch\r
 178     elseif ch="'" or ch="""" or ch="`" then\r
 179       inquote=true\r
 180       endquote=ch\r
 181       curfield=curfield & ch\r
 182     elseif ch="[" then\r
 183       inquote=true\r
 184       endquote="]"\r
 185       curfield=curfield & ch\r
 186     elseif ch="(" then\r
 187       parencnt=parencnt+1\r
 188       curfield=curfield & ch\r
 189     elseif ch=")" then\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
 195     elseif ch="," then\r
 196       'response.write "<p>" & clause & ": " & server.htmlencode(curfield) & "</p>"\r
 197       select case clause\r
 198         case "SELECT":\r
 199           SetParseField arSelList,curfield\r
 200           Push arSelListAs,Empty\r
 201         case "AS":\r
 202           arSelListAs(ubound(arSelList))=curfield\r
 203           curfield=""\r
 204           clause="SELECT"\r
 205         case "GROUP BY": SetParseField arGroupBy,curfield\r
 206         case "ORDER BY": SetParseField arOrderBy,curfield\r
 207         case else: curfield=curfield & ch\r
 208       end select\r
 209     elseif ch=" " then\r
 210       j=InStr(i+1,sqltext," ")\r
 211       if j<1 then\r
 212         curfield=curfield & ch\r
 213       else\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
 220             select case clause\r
 221               case "SELECT":\r
 222                 AddColumn curfield,Empty\r
 223                 curfield=""\r
 224               case "AS":\r
 225                 arSelListAs(ubound(arSelList))=curfield\r
 226                 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
 232             end select\r
 233             clause=nexttoken\r
 234             i=j-1\r
 235           case "AS":\r
 236             if clause="SELECT" then\r
 237               AddColumn curfield,Empty\r
 238               curfield=""\r
 239               clause=nexttoken\r
 240               i=j\r
 241             elseif curfield<>"" then\r
 242               curfield=curfield & ch\r
 243             end if\r
 244           case "DISTINCT":\r
 245             if clause="SELECT" then\r
 246               IsDistinct=true\r
 247               curfield=""\r
 248               i=j\r
 249             elseif curfield<>"" then\r
 250               curfield=curfield & ch\r
 251             end if\r
 252           case else: if curfield<>"" then curfield=curfield & ch\r
 253         end select\r
 254       end if\r
 255     else\r
 256       curfield=curfield & ch\r
 257     end if\r
 258     i=i+1\r
 259   wend\r
 260   ParseSelect=true\r
 261 end function\r
 262 \r
 263 \r
 264 Private sub Push(f, ByVal newvalue)\r
 265   ReDim Preserve f(ubound(f)+1)\r
 266   f(ubound(f))=newvalue\r
 267 end sub\r
 268 \r
 269 Private sub SetParseField(f, ByRef newvalue)\r
 270   if IsArray(f) then\r
 271     Push f,newvalue\r
 272   else\r
 273     f=newvalue\r
 274   end if\r
 275   newvalue=""\r
 276 end sub\r
 277 \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
 284 end sub\r
 285 \r
 286 Public Function LastColumn()\r
 287   LastColumn=arSelList(ubound(arSelList))\r
 288 end function\r
 289 \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
 296 end sub\r
 297 \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
 302     sortdir="ASC"\r
 303   elseif right(sortspec,4)="DESC" then\r
 304     sortcol=trim(left(sortspec,len(sortspec)-4))\r
 305     sortdir="DESC"\r
 306   else\r
 307     sortcol=trim(sortspec)\r
 308     sortdir=""\r
 309   end if\r
 310 End Sub\r
 311 \r
 312 Private Function FindSortColumn(ByVal sortspec)\r
 313   dim i, findcol, finddir, sortcol, sortdir\r
 314   FindSortColumn=-1\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
 319       FindSortColumn=i\r
 320       exit for\r
 321     end if\r
 322   next\r
 323 End Function\r
 324 \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
 329   dim i, colidx\r
 330   colidx=FindSortColumn(NewSort)\r
 331   if colidx>=0 then\r
 332     for i=colidx to 1 step -1\r
 333       arOrderBy(i)=arOrderBy(i-1)\r
 334     next\r
 335     arOrderBy(0)=NewSort\r
 336   else\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
 340     next\r
 341     arOrderBy(0)=NewSort\r
 342   end if\r
 343 end sub\r
 344 \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
 350 end sub\r
 351 \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
 357 end sub\r
 358 \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
 364 end sub\r
 365 \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
 370   Else\r
 371     Clause=Clause & " AND (" & NewCondition & ")"\r
 372   End If\r
 373 End Sub\r
 374 \r
 375 end class\r
 376 \r
 377 \r
 378 '********************************************************************************************************\r
 379 ' created by dbClass.GetColumnInfo()\r
 380 '********************************************************************************************************\r
 381 class dbColumn\r
 382   Public ColName,Nullable,ColType,ColLength,Writeable,IsPKey,FixedLength\r
 383 end class\r
 384 \r
 385 \r
 386 '********************************************************************************************************\r
 387 ' Manage a database connection\r
 388 '********************************************************************************************************\r
 389 class dbClass\r
 390 \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
 395 \r
 396 Private dbMain,DisplayFunc,dbDefault\r
 397 \r
 398 ' -------------------------------------------------------------\r
 399 ' Class Constructor\r
 400 ' -------------------------------------------------------------\r
 401 Private Sub Class_Initialize   ' Setup Initialize event.\r
 402   dim tw,tr\r
 403   SqlSvr = "localhost"\r
 404   Use_TSQL\r
 405   debug=false\r
 406   ConnTimeout=30        ' seconds\r
 407   LockTimeout=5000      ' milliseconds\r
 408   DisplayErrors=true\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
 414       ErrMsgFmt="1LINE"\r
 415       CmdTimeout = 3600   ' 60 minutes for wsh/cscript\r
 416       DisplayFunc="wscript.echo "\r
 417     end if\r
 418   elseif tr<>"Empty" then\r
 419     if IsObject(response) then\r
 420       ErrMsgFmt="HTML"\r
 421       CmdTimeout = 120    ' 2 minutes for asp pages\r
 422       DisplayFunc="response.write "\r
 423     end if\r
 424   else\r
 425     ErrMsgFmt="MULTILINE"\r
 426     CmdTimeout = 30\r
 427     DisplayFunc="msgbox "\r
 428   End If\r
 429   'DisplayMsg "Message format set to " & ErrMsgFmt\r
 430 End Sub\r
 431 \r
 432 Public function Connection()\r
 433   set Connection=dbMain\r
 434 end function\r
 435 \r
 436 Public Sub Use_TSQL()\r
 437   Dialect="TSQL"\r
 438   Provider="SQLOLEDB"\r
 439 End Sub\r
 440 \r
 441 Public Sub Use_Access(FileName)\r
 442   Dialect="Access"\r
 443   Provider="Microsoft.Jet.OLEDB.4.0"\r
 444   SqlSvr=FileName\r
 445 End Sub\r
 446 \r
 447 Public Sub Use_MySQL()\r
 448   Dialect="MySQL"\r
 449   OdbcDriver="{MySQL ODBC 3.51 Driver}"\r
 450 End Sub\r
 451 \r
 452 Public Sub Use_Oracle(SIM)\r
 453   Dialect="Oracle"\r
 454   'Provider="MSDAORA"\r
 455   Provider="OraOLEDB.Oracle"\r
 456   SqlSvr=SIM\r
 457 End Sub\r
 458 \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
 464   end select\r
 465 end function\r
 466 \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
 475   end select\r
 476 end function\r
 477 \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
 483   end select\r
 484 end function\r
 485 \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
 490   end select\r
 491 end function\r
 492 \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
 497   end select\r
 498 end function\r
 499 \r
 500 Public function Wildcard()\r
 501   Wildcard="%"\r
 502 end function\r
 503 \r
 504 Public function addQuotes(s)\r
 505   select case Dialect\r
 506     case "Access":\r
 507       if IsDate(s) then\r
 508         addQuotes="#" & s & "#"\r
 509       else\r
 510         addQuotes="""" & replace(s,"""","""""") & """"\r
 511       end if\r
 512     case "MySQL":  addQuotes="'" & replace(replace(s,"\","\\"),"'","\'") & "'"\r
 513     case else:     addQuotes="'" & replace(s,"'","''") & "'"\r
 514   end select\r
 515 end function\r
 516 \r
 517 Public function Concat(arStrings,addQuotes)\r
 518   dim i\r
 519   if addQuotes then\r
 520     for i=0 to ubound(arStrings)\r
 521       arStrings(i)=addQuotes(arStrings(i))\r
 522     next\r
 523   end if\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
 529   end select\r
 530 end function\r
 531 \r
 532 ' -------------------------------------------------------------\r
 533 ' Class Destructor\r
 534 ' -------------------------------------------------------------\r
 535 Private Sub Class_Terminate   ' Setup Terminate event.\r
 536   dbClose\r
 537 End Sub\r
 538 \r
 539 ' -------------------------------------------------------------\r
 540 ' If the database is down, then an explanation can be placed here\r
 541 ' -------------------------------------------------------------\r
 542 Public function MaintenanceMsg()\r
 543   MaintenanceMsg=""\r
 544 end function\r
 545 \r
 546 Public function DefaultDB()\r
 547   DefaultDB=dbDefault\r
 548 end function\r
 549 \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
 556   dim connstr\r
 557   dbDefault=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
 561   else\r
 562     connstr="DRIVER=" & OdbcDriver & ";SERVER=" & SqlSvr & ";Trusted_Connection=Yes;"\r
 563     if DefDB<>"" then connstr=connstr & "DATABASE=" & DefDB & ";"\r
 564   end if\r
 565   WinLogon=dbConnect(connstr)\r
 566 end function\r
 567 \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
 573   dim connstr\r
 574   dbDefault=DefDB\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
 579   else\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
 583   end if\r
 584   SqlLogon=dbConnect(connstr)\r
 585 end function\r
 586 \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
 593         exit function\r
 594   end if\r
 595   On Error Resume Next\r
 596   dbConnect=false\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
 600   end if\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
 607   dbConnect=true\r
 608 end function\r
 609 \r
 610 ' -------------------------------------------------------------\r
 611 ' Close database connection\r
 612 ' -------------------------------------------------------------\r
 613 Public sub dbClose\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
 618   end if\r
 619 End sub\r
 620 \r
 621 ' -------------------------------------------------------------\r
 622 ' return true if database connection is open\r
 623 ' -------------------------------------------------------------\r
 624 Public Function dbIsOpen\r
 625   dbIsOpen=false\r
 626   if IsObject(dbMain) then\r
 627     if dbMain.state <> 0 then dbIsOpen=true\r
 628   end if\r
 629 End Function\r
 630 \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
 642   end select\r
 643 End Function\r
 644 \r
 645 Private Function FixHtmlStr(s)\r
 646   FixHtmlStr=replace(replace(replace(s,"&","&amp;"),"<","&lt;"),"""","&quot;")\r
 647 End Function\r
 648 \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
 653     else\r
 654       msg=replace(msg,vbLf," ")\r
 655     end if\r
 656     execute DisplayFunc & """" & replace(msg,"""","""""") & """"\r
 657   End If\r
 658 end sub\r
 659 \r
 660 Private sub HandleError(msg)\r
 661   LastErrorMsg=msg\r
 662   if DisplayErrors then DisplayMsg LastErrorMsg\r
 663 End sub\r
 664 \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
 671   CheckForError=true\r
 672   if IsEmpty(ErrMsgFmt) Then exit function\r
 673   HandleError FormatErrorMsg(msg)\r
 674 End function\r
 675 \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
 682   Dim rsLookUp\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
 687     Exit Function\r
 688   End If\r
 689   If debug then DisplayMsg sqltext\r
 690   If Not rsLookUp.EOF Then rsLookUp.MoveFirst\r
 691   Set RunQuery = rsLookUp\r
 692 End Function\r
 693 \r
 694 \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
 710     Exit Function\r
 711   End If\r
 712   If debug then DisplayMsg sqltext\r
 713   set objCmd = Nothing\r
 714   Set RunParamQuery = rsLookUp\r
 715 End Function\r
 716 \r
 717 \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
 725         rsLookUp.Close\r
 726       End If\r
 727       Set rsLookUp = Nothing\r
 728     End If\r
 729   End If\r
 730 End Sub\r
 731 \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
 740   Dim rsMain, i\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
 748       Next\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
 752       Next\r
 753     Else\r
 754       dicData = rsMain.Fields(0).Value\r
 755     End If\r
 756     SingleRecordQuery = True\r
 757   End If\r
 758   rsClose rsMain\r
 759 End Function\r
 760 \r
 761 \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
 769   RunActionQuery = 0\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
 774     Exit Function\r
 775   ElseIf debug then\r
 776     DisplayMsg sqltext\r
 777     if not IsEmpty(RecordsAffected) and not IsNull(RecordsAffected) then\r
 778       DisplayMsg RecordsAffected & " records affected"\r
 779     end if\r
 780   End If\r
 781   RunActionQuery = RecordsAffected\r
 782 End Function\r
 783 \r
 784 \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
 793   LastErrorMsg=Empty\r
 794   RunActionQueryReturnMsg=RunActionQuery(sqltext)\r
 795   if not IsEmpty(LastErrorMsg) then errmsg=LastErrorMsg\r
 796   DisplayErrors=tmpDisplayErrors\r
 797 end function\r
 798 \r
 799 \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
 803 '   2) the create\r
 804 '   3) grants select access to public (if not a temp table)\r
 805 '\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
 820   end if\r
 821 end sub\r
 822 \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
 833   end select\r
 834 end function\r
 835 \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
 877    End Select\r
 878 End Function\r
 879 \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
 889     rsClose rsLookUp\r
 890   else\r
 891     rsClose rsLookUp\r
 892     sqltext="sp_helptext '" & viewname & "'"\r
 893     set rsLookUp = RunQuery(sqltext)\r
 894     sqltext=""\r
 895     Do while not rsLookUp.EOF\r
 896       sqltext=sqltext & rsLookUp("Text")\r
 897         rsLookUp.movenext\r
 898     Loop\r
 899     rsClose rsLookUp\r
 900     sqltext=replace(sqltext,"CREATE VIEW ","ALTER VIEW ",1,-1,1)\r
 901     RunActionQuery sqltext\r
 902   end if\r
 903 end sub\r
 904 \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
 910   dim arNames,last\r
 911 \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
 916     owner=empty\r
 917     dbname=empty\r
 918     table=ucase(table)\r
 919     exit sub\r
 920   end if\r
 921   if last>0 then\r
 922     owner=arNames(last-1)\r
 923   else\r
 924     owner="dbo"\r
 925   end if\r
 926   if last>1 then\r
 927     dbname=arNames(last-2)\r
 928   else\r
 929     dbname=dbDefault\r
 930   end if\r
 931 end sub\r
 932 \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
 941 end function\r
 942 \r
 943 \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
 949   db=dbDefault\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
 957 end sub\r
 958 \r
 959 \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
 970   end select\r
 971 end function\r
 972 \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
 986   end if\r
 987   Set EnumColumnsADO = reval\r
 988 end function\r
 989 \r
 990 \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
 996   Dim rs,colnames\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
1000   While Not rs.EOF\r
1001     if IsEmpty(colnames) then colnames=rs("COLUMN_NAME") else colnames=colnames & "," & rs("COLUMN_NAME")\r
1002     rs.MoveNext\r
1003   Wend\r
1004   rs.Close\r
1005   PrimaryKey=colnames\r
1006 end function\r
1007 \r
1008 \r
1009 ' returns number of columns, or -1 if there was en error\r
1010 Public function GetColumnInfo (ByVal TableName, ByRef arColumns)\r
1011   dim rs,cnt,i\r
1012   GetColumnInfo=-1\r
1013   If debug then DisplayMsg "Getting column info for: " & TableName\r
1014   SplitTabName TableName,dbname,owner,table\r
1015   cnt=0\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
1019   While Not rs.EOF\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
1028       else\r
1029         .ColLength=rs("CHARACTER_MAXIMUM_LENGTH")\r
1030       end if\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
1034       .IsPKey=false\r
1035     end with\r
1036     cnt=cnt+1\r
1037     rs.MoveNext\r
1038   Wend\r
1039   rs.Close\r
1040 \r
1041   Set rs = EnumColumnsADO(28,TableName)\r
1042   if rs is Nothing Then exit function\r
1043   While Not rs.EOF\r
1044     for i=0 to cnt-1\r
1045       if arColumns(i).ColName=rs("COLUMN_NAME") then\r
1046         arColumns(i).IsPKey=true\r
1047         exit for\r
1048       end if\r
1049     next\r
1050     rs.MoveNext\r
1051   Wend\r
1052   rs.Close\r
1053   GetColumnInfo=cnt\r
1054   if Dialect <> "Access" then exit function\r
1055 \r
1056   ' check for AutoNumber columns\r
1057   dim ADOXcat,cols\r
1058   Set ADOXcat = CreateObject("ADOX.Catalog")\r
1059   Set ADOXcat.ActiveConnection = dbMain\r
1060   Set cols=ADOXcat.Tables(table).Columns\r
1061   for i=0 to cnt-1\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
1065     End If\r
1066   next\r
1067   Set ADOXcat = Nothing\r
1068 end function\r
1069 \r
1070 \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
1078   \r
1079   GenCreateFromTable=""\r
1080   sqltext=""\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
1088     else\r
1089       sqltext=sqltext & "," & vbLf\r
1090     end if\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
1096     end if\r
1097     if rsLookUp("NULLABLE") = 0 then\r
1098       sqltext=sqltext & " NOT NULL"\r
1099     else\r
1100       sqltext=sqltext & " NULL"\r
1101     end if\r
1102         rsLookUp.movenext\r
1103   Loop\r
1104   sqltext=sqltext & vbLf & ")"\r
1105   rsClose rsLookUp\r
1106   GenCreateFromTable=sqltext\r
1107 end function\r
1108 \r
1109 \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
1117   Else\r
1118     WhereClause=WhereClause & " AND (" & NewCondition & ")"\r
1119   End If\r
1120 End Sub\r
1121 \r
1122 \r
1123 end class\r
1124 \r
1125 %>\r