Automating QTP Test Automation Home Automation Articles Downloads QTP Gotchas Links Books Contact About Site Map
Automate - SQL - Sql Server 2000If you find an error, or have a suggestion for improvement, Email me and I'll fix it. This code generates a function library containing SQL code for manipulating the Sql-Server 2000 database you point it at. This code has been designed for Sql-Server 2000, it might work with later versions of Sql-Server, but I haven't tried it. To function correctly, this generator must be supplied with:
The Server name For SAFETY, the generated code has all the SQL Executes commented OUT. YOU MUST review the code before turning the Executes back on.
While this generator only performs READS on a database... The code that is PRODUCED BY this generator CAN DAMAGE YOUR DATA if called incorrectly. DO NOT use this code on a LIVE database. You use this code ENTIRELY at your own risk (see the terms of use). To use, just save this code into a .qfl file, add it to your project and then 'Call GenSql_SqlSvr' to run it. It will ask you various questions and then generate a new .qfl function library file containing the SQL code. Download it Here (right-click and then save target as). (NOTE - you can just cut & paste from below, but the formatting will have multiple spaces instead of tabs).
'=========================================================================
Option Explicit 'NOTE - For safety, the SQL Executes in the generated code are commented out 'Please carefully review the generated code before turning the Executes on Sub GenSql_SqlSvr Dim sServer, sDatabase, sUser, sPassword If GetDatabaseConnection(sServer,sDatabase,sUser,sPassword) Then Call ProcessDatabase(sServer,sDatabase,sUser,sPassword) End If End Sub '======================================== Private Function GetDatabaseConnection(sServer, sDatabase, sUser, sPassword) Dim sCon, oCon, iErr, sErr sServer = "localhost" sDatabase = "Northwind" sUser = "sa" sPassword = "password" 'Get User interactions sServer = Inputbox ("Enter the name of your Server:", "User Input Required", sServer) If sServer = "" Then Call ExitTest() End If sDatabase = Inputbox ("Enter the name of your Database:", "User Input Required", sDatabase) If sDatabase = "" Then Call ExitTest() End If sUser = Inputbox ("Enter a Username for that database:", "User Input Required", sUser) If sUser = "" Then Call ExitTest() End If sPassword = Inputbox ("Enter a Password for that user:", "User Input Required", sPassword) If sPassword = "" Then Call ExitTest() End If 'Assemble the connection string (Sql-Server-2000) sCon = "Driver={SQL Server};Server=" & sServer & ";Database=" & sDatabase & ";Uid=" & sUser & ";Pwd=" & sPassword & ";" Set oCon = CreateObject("adodb.connection") 'Set connection timeout (default is 15 seconds)? 'oCon.ConnectionTimeout = 1 'Try to connect On Error Resume Next oCon.Open sCon iErr = Err.Number sErr = Err.Description On Error GoTo 0 'Handle Errors If iErr <> 0 Then GetDatabaseConnection = False If iErr = -2147467259 Then Msgbox "SQL Server does not exist or access denied",vbCritical,"SQL-Server Connection Error:" ElseIf iErr = -2147217843 Then Msgbox "Login Failed for User - Invalid User name or Password",vbCritical,"SQL-Server Connection Error:" Else Msgbox cStr(iErr) & " - " & sErr,vbCritical,"SQL-Server Undiagnosed Connection Error:" End If Else GetDatabaseConnection = True oCon.Close End If Set oCon = Nothing End Function '======================================== Private Function ProcessDatabase(sServer,sDatabase,sUser,sPassword) Dim sCon, oCon, asTables(49,1), asFields(49,49,3), iTableCount sCon = "Driver={SQL Server};Server=" & sServer & ";Database=" & sDatabase & ";Uid=" & sUser & ";Pwd=" & sPassword & ";" Set oCon = CreateObject("adodb.connection") oCon.Open sCon iTableCount = GetDatabaseTables(oCon,asTables) Call GetDatabaseFields(oCon,iTableCount,asTables,asFields) Call ProcessArray(iTableCount,asTables,asFields) oCon.Close Set oCon = Nothing Call GenerateOutput(sCon,sServer,sDatabase,iTableCount,asTables,asFields) End Function '======================================== Private Function GetDatabaseTables(oCon,asTables) Dim oRec, sSql, iTableCount, sTable iTableCount = 0 Set oRec = CreateObject("ADODB.Recordset") sSql = "SELECT name FROM sysobjects WHERE xtype = 'U'" oRec.Open sSQL, oCon If NOT oRec.Eof Then oRec.MoveFirst While NOT oRec.Eof sTable = oRec.Fields("name") asTables(iTableCount,0) = sTable iTableCount = iTableCount + 1 oRec.MoveNext Wend End If oRec.Close Set oRec = Nothing GetDatabaseTables = iTableCount End Function '======================================== Private Sub GetDatabaseFields(oCon,iTableCount,asTables,asFields) Dim iTableIndex For iTableIndex = 0 to iTableCount-1 asTables(iTableIndex,1) = GetTableFields(oCon,iTableIndex,asTables,asFields) Next End Sub '======================================== Private Function GetTableFields(oCon,iTableIndex,asTables,asFields) Dim sTable, oRec, sSql, iFieldCount, sFieldName, sFieldType sTable = asTables(iTableIndex,0) iFieldCount = 0 Set oRec = CreateObject("ADODB.Recordset") sSql = "SELECT c.name AS fname, c.xtype AS ftype, c.status AS fstatus FROM sysobjects o JOIN syscolumns c ON c.id = o.id WHERE o.name = '" & sTable & "'" oRec.Open sSQL, oCon If NOT oRec.Eof Then oRec.MoveFirst While NOT oRec.Eof asFields(iTableIndex,iFieldCount,0) = oRec.Fields("fname") asFields(iTableIndex,iFieldCount,1) = oRec.Fields("ftype") asFields(iTableIndex,iFieldCount,2) = oRec.Fields("fstatus") iFieldCount = iFieldCount + 1 oRec.MoveNext Wend End If Print "Fields Found: " & cStr(iFieldCount) GetTableFields = iFieldCount oRec.Close Set oRec = Nothing End Function '======================================== Private Sub ProcessArray(iTableCount,asTables,asFields) Dim iTableIndex, iFieldCount, iFieldIndex, sFieldName, sFieldType, sFieldStatus For iTableIndex = 0 to iTableCount-1 iFieldCount = asTables(iTableIndex,1) For iFieldIndex = 0 to iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) Select Case sFieldType Case 35, 99, 167, 175, 231, 239 asFields(iTableIndex,iFieldIndex,3) = "s" 'Strings Case 58, 61 asFields(iTableIndex,iFieldIndex,3) = "d" 'Dates Case 60, 122 asFields(iTableIndex,iFieldIndex,3) = "m" 'Money Case 104, 48, 52, 56, 59, 62, 106, 108, 127 asFields(iTableIndex,iFieldIndex,3) = "i" 'Numerics Case Else asFields(iTableIndex,iFieldIndex,3) = "x" 'Not Handled End Select Next Next End Sub '======================================== Private Sub GenerateOutput(sCon,sServer, sDatabase,iTableCount,asTables,asFields) Dim sApp, sFileName, oFso, oFile Const ForWriting = 2, TristateTrue = -1 'Get the Application Mnemonic sApp = "App" sApp = Inputbox ("Enter a name for your application (3 - 4 chars are ideal):", "User Input Required", sApp) If sApp = "" Then Call ExitTest() End If 'Get the User to confirm the file name sFileName = "C:\Program Files\HP\QuickTest Professional\Tests\" & sApp & "_" & sDatabase & "_SQL.qfl" sFileName = Inputbox ("Confirm generated file name:", "User Input Required", sFileName) If sFileName = "" Then Call ExitTest() End If 'Open the file (in Unicode) Set oFso = CreateObject("Scripting.FileSystemObject") Set oFile = oFso.OpenTextFile(sFileName, ForWriting, True, TristateTrue) 'Write header oFile.WriteLine("Option Explicit") oFile.WriteLine("'--------------") oFile.WriteLine("") oFile.WriteLine("'Database SQL Functions") oFile.WriteLine("") oFile.WriteLine("'For App : " & sApp) oFile.WriteLine("'For Server : " & sServer) oFile.WriteLine("'For Database : " & sDatabase) oFile.WriteLine("") oFile.WriteLine("'Automatically Generated by the Intellipro SQL Sql-Server 2000 Code Generator") oFile.WriteLine("") oFile.WriteLine("'" & String(40,"=")) oFile.WriteLine("") 'For each table generate the SQL Dim iTableIndex For iTableIndex = 0 to iTableCount-1 Call GenTableOutput(sCon,oFile,sApp,sDatabase,iTableIndex,asTables,asFields) Next 'Footer oFile.WriteLine("") oFile.WriteLine("'" & String(40,"#")) oFile.Close End Sub '======================================== Private Sub GenTableOutput(sCon,oFile,sApp,sDatabase,iTableIndex,asTables,asFields) Call GenSqlAdd(sCon,oFile,sApp,iTableIndex,asTables,asFields) Call GenSqlGet(sCon,oFile,sApp,iTableIndex,asTables,asFields) Call GenSqlUpdate(sCon,oFile,sApp,iTableIndex,asTables,asFields) Call GenSqlDelete(sCon,oFile,sApp,iTableIndex,asTables,asFields) Call GenSqlExists(sCon,oFile,sApp,iTableIndex,asTables,asFields) End Sub '======================================== Private Sub GenSqlAdd(sCon,oFile,sApp,iTableIndex,asTables,asFields) Dim sTableName, sTableNameF, sParam, iLineCount, iFieldIndex, iFieldCount, sFieldName, sFieldType, sFieldStatus, sFieldClass, sQ, bQ sQ = Chr(34) sTableName = asTables(iTableIndex,0) sTableNameF = GetFunctionSafeTableName(sTableName) iFieldCount = asTables(iTableIndex,1) sParam = GetParamAdd(iTableIndex,asTables,asFields) 'Write header oFile.WriteLine("") oFile.WriteLine("Function " & sApp & "Sql_" & sTableNameF & "_Add(" & sParam & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Add an Entry to the " & sTableName & " table") 'Dump what we know about the table Call Datadump(oFile,iTableIndex,asTables,asFields) oFile.WriteLine(vbTab & "Dim oCon, oRec, sSql, lIdentity") oFile.WriteLine("") oFile.WriteLine(vbTab & "lIdentity = 0") oFile.WriteLine("") 'Code to assemble the SQL oFile.WriteLine(vbTab & "sSql = " & sQ & "INSERT INTO " & sTableName & sQ) oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "(" & sQ) oFile.WriteLine("") 'Database Fields iLineCount = 0 For iFieldIndex = 0 to iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) If (sFieldType = 56) AND (sFieldStatus = 128) Then 'Ignore ElseIf sFieldClass = "x" Then 'Ignore Else iLineCount = iLineCount + 1 If iLineCount = 1 Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & sFieldName & sQ) Else oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "," & sQ & " & " & sQ & sFieldName & sQ) End If End If Next oFile.WriteLine("") oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & ") VALUES (" & sQ) oFile.WriteLine("") 'Values bQ = False iLineCount = 0 For iFieldIndex = 0 to iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) If (sFieldType = 56) AND (sFieldStatus = 128) Then 'Ignore ElseIf sFieldClass = "x" Then 'Ignore Else iLineCount = iLineCount + 1 If iLineCount = 1 Then If sFieldClass = "s" Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "'" & sQ & " & " & sFieldClass & sFieldName) bQ = True Else oFile.WriteLine(vbTab & "sSql = sSql & cStr(" & sFieldClass & sFieldName & ")") bQ = False End If Else If sFieldClass = "s" Then If bQ Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "','" & sQ & " & " & sFieldClass & sFieldName) Else oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & ",'" & sQ & " & " & sFieldClass & sFieldName) End If bQ = True Else If bQ Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "'," & sQ & " & cStr(" & sFieldClass & sFieldName & ")") Else oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "," & sQ & " & cStr(" & sFieldClass & sFieldName & ")") End If bQ = False End If End If End If Next oFile.WriteLine("") If bQ Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "')" & sQ) Else oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & ")" & sQ) End If oFile.WriteLine("") oFile.WriteLine(vbTab & "sSql = sSql & vbCrLf") oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "SELECT @@Identity" & sQ) oFile.WriteLine(vbTab & "sSql = sSql & vbCrLf") oFile.WriteLine("") oFile.WriteLine(vbTab & "Print sSql") oFile.WriteLine(vbTab & "Msgbox sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = CreateObject(" & sQ & "ADODB.Connection" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oRec = CreateObject(" & sQ & "ADODB.Recordset" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Open " & sQ & sCon & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "'########## WARNING ##########") oFile.WriteLine("") oFile.WriteLine(vbTab & "'This code can damage your data") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Review it carefully BEFORE turning the Execute ON") oFile.WriteLine("") oFile.WriteLine(vbTab & "MsgBox " & sQ & "SQL Execute is currently turned off, remove comment to activate" & sQ & ", vbExclamation, " & sQ & "Function: " & sApp & "Sql_" & sTableNameF & "_Add" & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "'Set oRec = oCon.Execute (sSql)") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Set oRec = oRec.NextRecordSet()") oFile.WriteLine("") oFile.WriteLine(vbTab & "'lIdentity = oRec(0)") oFile.WriteLine("") oFile.WriteLine(vbTab & "'oRec.Close") oFile.WriteLine("") oFile.WriteLine(vbTab & "'#############################") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Close") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oRec = Nothing") oFile.WriteLine(vbTab & "Set oCon = Nothing") oFile.WriteLine("") oFile.WriteLine( vbTab & sApp & "Sql_" & sTableNameF & "_Add = lIdentity") oFile.WriteLine("") oFile.WriteLine("End Function") oFile.WriteLine("") oFile.WriteLine("'" & String(40,"=")) End Sub '======================================== Private Sub GenSqlGet(sCon,oFile,sApp,iTableIndex,asTables,asFields) Dim sTableName, sTableNameF, sParam, iLineCount, iFieldIndex, iFieldCount, sFieldName, sFieldType, sFieldStatus, sFieldClass, sQ, bQ Dim iKeyFieldIndex, sKeyFieldName, sKeyFieldClass, sLine, iPad sQ = Chr(34) sTableName = asTables(iTableIndex,0) sTableNameF = GetFunctionSafeTableName(sTableName) iFieldCount = asTables(iTableIndex,1) iPad = GetLongestFieldName(iTableIndex,asTables,asFields) sParam = GetParamUpdate(iTableIndex,asTables,asFields) iKeyFieldIndex = GetKeyFieldIndex(iTableIndex,asTables, asFields) If iKeyFieldIndex = -1 Then sKeyFieldName = "Xxxx" sKeyFieldClass = "x" Else sKeyFieldName = asFields(iTableIndex,iKeyFieldIndex,0) sKeyFieldClass = asFields(iTableIndex,iKeyFieldIndex,3) End If 'Header oFile.WriteLine("") oFile.WriteLine("Function " & sApp & "Sql_" & sTableNameF & "_Get(" & sParam & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Get an Entry from the " & sTableName & " table") 'Dump what we know about the table Call Datadump(oFile,iTableIndex,asTables,asFields) oFile.WriteLine(vbTab & "Dim oCon, oRec, sSql") oFile.WriteLine("") If sKeyFieldClass = "s" Then oFile.WriteLine(vbTab & "sSql = " & sQ & "SELECT * FROM " & sTableName & " WHERE " & sKeyFieldName & " = '" & sQ & " & " & sKeyFieldClass & sKeyFieldName & " & " & sQ & "'" & sQ) Else oFile.WriteLine(vbTab & "sSql = " & sQ & "SELECT * FROM " & sTableName & " WHERE " & sKeyFieldName & " = " & sQ & " & cStr(" & sKeyFieldClass & sKeyFieldName & ")") End If oFile.WriteLine("") oFile.WriteLine(vbTab & "Print sSql") oFile.WriteLine(vbTab & "Msgbox sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = CreateObject(" & sQ & "ADODB.Connection" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oRec = CreateObject(" & sQ & "ADODB.Recordset" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Open " & sQ & sCon & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "oRec.Open sSQL,oCon") oFile.WriteLine("") oFile.WriteLine(vbTab & "If oRec.Eof Then") oFile.WriteLine(vbTab & vbTab & sApp & "Sql_" & sTableName & "_Get = False") oFile.WriteLine("") oFile.WriteLine(vbTab & "Else") oFile.WriteLine(vbTab & vbTab & sApp & "Sql_" & sTableName & "_Get = True") oFile.WriteLine("") oFile.WriteLine(vbTab & vbTab & "oRec.MoveFirst") oFile.WriteLine("") 'Database Fields For iFieldIndex = 0 to iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) If (sFieldType = 56) AND (sFieldStatus = 128) Then 'Ignore ElseIf sFieldClass = "x" Then 'Ignore Else If sFieldClass = "s" Then sLine = vbTab & vbTab & Left(sFieldClass & sFieldName & Space(iPad+2),iPad+2) & " = oRec.Fields(" & sQ & sFieldName & sQ & ")" Else sLine = vbTab & vbTab & Left(sFieldClass & sFieldName & Space(iPad+2),iPad+2) & " = oRec.Fields(" & sQ & sFieldName & sQ & ")" End If oFile.WriteLine(sLine) End If Next 'Footer oFile.WriteLine("") oFile.WriteLine(vbTab & "End If") oFile.WriteLine("") oFile.WriteLine(vbTab & "oRec.Close") oFile.WriteLine(vbTab & "oCon.Close") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oRec = Nothing") oFile.WriteLine(vbTab & "Set oCon = Nothing") oFile.WriteLine("") oFile.WriteLine("End Function") oFile.WriteLine("") oFile.WriteLine("'" & String(40,"=")) End Sub '======================================== Private Sub GenSqlUpdate(sCon,oFile,sApp,iTableIndex,asTables,asFields) Dim sTableName, sTableNameF, sParam, iLineCount, iFieldIndex, iFieldCount, sFieldName, sFieldType, sFieldStatus, sFieldClass, sQ, bQ Dim iKeyFieldIndex, sKeyFieldName, sKeyFieldClass, sLine, iPad sQ = Chr(34) sTableName = asTables(iTableIndex,0) sTableNameF = GetFunctionSafeTableName(sTableName) iFieldCount = asTables(iTableIndex,1) iPad = GetLongestFieldName(iTableIndex,asTables,asFields) sParam = GetParamUpdate(iTableIndex,asTables,asFields) iKeyFieldIndex = GetKeyFieldIndex(iTableIndex,asTables, asFields) If iKeyFieldIndex = -1 Then sKeyFieldName = "Xxxx" sKeyFieldClass = "x" Else sKeyFieldName = asFields(iTableIndex,iKeyFieldIndex,0) sKeyFieldClass = asFields(iTableIndex,iKeyFieldIndex,3) End If 'Write header oFile.WriteLine("") oFile.WriteLine("Sub " & sApp & "Sql_" & sTableNameF & "_Update(" & sParam & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Update an Entry in the " & sTableName & " table") 'Dump what we know about the table Call Datadump(oFile,iTableIndex,asTables,asFields) oFile.WriteLine(vbTab & "Dim oCon, sSql") oFile.WriteLine("") 'Create the SQL for the Update oFile.WriteLine("") oFile.WriteLine(vbTab & "sSql = " & sQ & "UPDATE " & sTableName & sQ) oFile.WriteLine("") oFile.WriteLine( vbTab & "sSql = sSql & " & sQ & " SET " & sQ) oFile.WriteLine("") 'Database Fields iLineCount = 0 bQ = False For iFieldIndex = 0 to iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) If (sFieldType = 56) AND (sFieldStatus = 128) Then 'Ignore ElseIf sFieldClass = "x" Then 'Ignore Else iLineCount = iLineCount + 1 If iLineCount = 1 Then If sFieldClass = "s" Then sLine = vbTab & "sSql = sSql & " & sQ & Left(sFieldName & sQ & Space(iPad),iPad+1) sLine = sLine & " & " & sQ & " = '" & sQ & " & " & sFieldClass & sFieldName bQ = True Else sLine = vbTab & "sSql = sSql & " & sQ & Left(sFieldName & sQ & Space(iPad),iPad+1) sLine = sLine & " & " & sQ & " = " & sQ & " & cStr(" & sFieldClass & sFieldName & ")" bQ = False End If Else If sFieldClass = "s" Then If bQ Then sLine = vbTab & "sSql = sSql & " & sQ & "'," & sQ & " & " & sQ & Left(sFieldName & sQ & Space(iPad),iPad+1) sLine = sLine & " & " & sQ & " = '" & sQ & " & " & sFieldClass & sFieldName Else sLine = vbTab & "sSql = sSql & " & sQ & "," & sQ & " & " & sQ & Left(sFieldName & sQ & Space(iPad),iPad+1) sLine = sLine & " & " & sQ & " = '" & sQ & " & " & sFieldClass & sFieldName End If bQ = True Else If bQ Then sLine = vbTab & "sSql = sSql & " & sQ & "'," & sQ & " & " & sQ & Left(sFieldName & sQ & Space(iPad),iPad+1) sLine = sLine & " & " & sQ & " = " & sQ & " & cStr(" & sFieldClass & sFieldName & ")" Else sLine = vbTab & "sSql = sSql & " & sQ & "," & sQ & " & " & sQ & Left(sFieldName & sQ & Space(iPad),iPad+1) sLine = sLine & " & " & sQ & " = " & sQ & " & cStr(" & sFieldClass & sFieldName & ")" End If bQ = False End If End If oFile.WriteLine(sLine) End If Next oFile.WriteLine("") If sKeyFieldClass = "s" Then If bQ Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "'" & sQ & " & " & sQ & "WHERE " & Left(sKeyFieldName & sQ & Space(iPad),iPad+1) & " & " & sQ & " = '" & sQ & " & " & sKeyFieldClass & sKeyFieldName & " & " & sQ & "'" & sQ) Else oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & " WHERE " & Left(sKeyFieldName & sQ & Space(iPad),iPad+1) & " & " & sQ & " = '" & sQ & " & " & sKeyFieldClass & sKeyFieldName & " & " & sQ & "'" & sQ) End If Else If bQ Then oFile.WriteLine(vbTab & "sSql = sSql & " & sQ & "' " & sQ & " & " & sQ & "WHERE " & Left(sKeyFieldName & sQ & Space(iPad),iPad+1) & " & " & sQ & " = " & sQ & " & cStr(" & sKeyFieldClass & sKeyFieldName & ")") Else oFile.WriteLine(vbTab & "sSql = sSql & " & " " & sQ & "WHERE " & Left(sKeyFieldName & sQ & Space(iPad),iPad+1) & " & " & sQ & " = " & sQ & " & cStr(" & sKeyFieldClass & sKeyFieldName & ")") End If End If 'Footer oFile.WriteLine("") oFile.WriteLine("") oFile.WriteLine(vbTab & "Print sSql") oFile.WriteLine(vbTab & "Msgbox sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = CreateObject(" & sQ & "ADODB.Connection" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Open " & sQ & sCon & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "'########## WARNING ##########") oFile.WriteLine("") oFile.WriteLine(vbTab & "'This code can damage your data") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Review it carefully BEFORE turning the Execute ON") oFile.WriteLine("") oFile.WriteLine(vbTab & "MsgBox " & sQ & "SQL Execute is currently turned off, remove comment to activate" & sQ & ", vbExclamation, " & sQ & "Function: " & sApp & "Sql_" & sTableNameF & "_Update" & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "'oCon.Execute sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "'#############################") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Close") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = Nothing") oFile.WriteLine("") oFile.WriteLine("End Sub") oFile.WriteLine("") oFile.WriteLine("'" & String(40,"=")) End Sub '======================================== Private Sub GenSqlDelete(sCon,oFile,sApp,iTableIndex,asTables,asFields) Dim sTableName, sTableNameF, sKeyFieldName, iKeyFieldIndex, sKeyFieldClass, sQ sQ = Chr(34) sTableName = asTables(iTableIndex,0) sTableNameF = GetFunctionSafeTableName(sTableName) iKeyFieldIndex = GetKeyFieldIndex(iTableIndex,asTables, asFields) If iKeyFieldIndex = -1 Then sKeyFieldName = "Xxxx" sKeyFieldClass = "x" Else sKeyFieldName = asFields(iTableIndex,iKeyFieldIndex,0) sKeyFieldClass = asFields(iTableIndex,iKeyFieldIndex,3) End If 'Header oFile.WriteLine("") oFile.WriteLine("Sub " & sApp & "Sql_" & sTableNameF & "_Delete(" & sKeyFieldClass & sKeyFieldName & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Deletes an Entry from the " & sTableName & " table") Call Datadump(oFile,iTableIndex,asTables,asFields) oFile.WriteLine(vbTab & "Dim oCon, sSql") oFile.WriteLine("") If sKeyFieldClass = "s" Then oFile.WriteLine(vbTab & "sSql = " & sQ & "DELETE FROM " & sTableName & " WHERE " & sKeyFieldName & " = '" & sQ & " & " & sKeyFieldClass & sKeyFieldName & " & " & sQ & "'" & sQ) Else oFile.WriteLine(vbTab & "sSql = " & sQ & "DELETE FROM " & sTableName & " WHERE " & sKeyFieldName & " = " & sQ & " & cStr(" & sKeyFieldClass & sKeyFieldName & ")") End If 'Footer oFile.WriteLine("") oFile.WriteLine(vbTab & "Print sSql") oFile.WriteLine(vbTab & "Msgbox sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = CreateObject(" & Chr(34) & "ADODB.Connection" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Open " & sQ & sCon & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "'########## WARNING ##########") oFile.WriteLine("") oFile.WriteLine(vbTab & "'This code can damage your data") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Review it carefully BEFORE turning the Execute ON") oFile.WriteLine("") oFile.WriteLine(vbTab & "MsgBox " & sQ & "SQL Execute is currently turned off, remove comment to activate" & sQ & ", vbExclamation, " & sQ & "Function: " & sApp & "Sql_" & sTableNameF & "_Delete" & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "'oCon.Execute sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "'#############################") oFile.WriteLine("") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Close") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = Nothing") oFile.WriteLine("") oFile.WriteLine("End Sub") oFile.WriteLine("") oFile.WriteLine("'" & String(40,"=")) End Sub '======================================== Private Sub GenSqlExists(sCon,oFile,sApp,iTableIndex,asTables,asFields) Dim sTableName, sTableNameF, iKeyFieldIndex, sKeyFieldName, sKeyFieldClass, sQ sQ = Chr(34) sTableName = asTables(iTableIndex,0) sTableNameF = GetFunctionSafeTableName(sTableName) iKeyFieldIndex = GetKeyFieldIndex(iTableIndex,asTables, asFields) If iKeyFieldIndex = -1 Then sKeyFieldName = "xxxx" sKeyFieldClass = "x" Else sKeyFieldName = asFields(iTableIndex,iKeyFieldIndex,0) sKeyFieldClass = asFields(iTableIndex,iKeyFieldIndex,3) End If 'Header oFile.WriteLine("") oFile.WriteLine("Function " & sApp & "Sql_" & sTableNameF & "_Exists(" & sKeyFieldClass & sKeyFieldName & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "'Checks if an entry exists in the " & sTableName & " table") Call Datadump(oFile,iTableIndex,asTables,asFields) oFile.WriteLine(vbTab & "Dim oCon, oRec, sSql") oFile.WriteLine("") If sKeyFieldClass = "s" Then oFile.WriteLine(vbTab & "sSql = " & sQ & "SELECT * FROM " & sTableName & " WHERE " & sKeyFieldName & " = '" & sQ & " & " & sKeyFieldClass & sKeyFieldName & " & " & sQ & "'" & sQ) Else oFile.WriteLine(vbTab & "sSql = " & sQ & "SELECT * FROM " & sTableName & " WHERE " & sKeyFieldName & " = " & sQ & " & cStr(" & sKeyFieldClass & sKeyFieldName & ")") End If 'Footer oFile.WriteLine("") oFile.WriteLine(vbTab & "Print sSql") oFile.WriteLine(vbTab & "Msgbox sSql") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oCon = CreateObject(" & sQ & "ADODB.Connection" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oRec = CreateObject(" & sQ & "ADODB.Recordset" & sQ & ")") oFile.WriteLine("") oFile.WriteLine(vbTab & "oCon.Open " & sQ & sCon & sQ) oFile.WriteLine("") oFile.WriteLine(vbTab & "oRec.Open sSQL,oCon") oFile.WriteLine("") oFile.WriteLine(vbTab & "If oRec.EOF Then") oFile.WriteLine(vbTab & vbTab & sApp & "Sql_" & sTableName & "_Exists = False") oFile.WriteLine("") oFile.WriteLine(vbTab & "Else") oFile.WriteLine(vbTab & vbTab & sApp & "Sql_" & sTableName & "_Exists = True") oFile.WriteLine("") oFile.WriteLine(vbTab & "End If") oFile.WriteLine("") oFile.WriteLine(vbTab & "oRec.Close") oFile.WriteLine(vbTab & "oCon.Close") oFile.WriteLine("") oFile.WriteLine(vbTab & "Set oRec = Nothing") oFile.WriteLine(vbTab & "Set oCon = Nothing") oFile.WriteLine("") oFile.WriteLine("End Function") oFile.WriteLine("") oFile.WriteLine("'" & String(40,"=")) End Sub '======================================== Private Function GetFunctionSafeTableName(sInput) 'This function converts a table name to one that is safe to use in a function name 'Database tables can contain spaces! (I don't recommend it) Dim sOutput sOutput = Replace(sInput, " ", "_") 'Add other adjustments here... GetFunctionSafeTableName = sOutput End Function '======================================== Private Function GetLongestFieldName(iTableIndex,asTables, asFields) Dim iLongest, iFieldCount, iFieldIndex, sFieldName, iFieldNameLength iLongest = 0 iFieldCount = asTables(iTableIndex,1) For iFieldIndex = 0 To iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) iFieldNameLength = Len(sFieldName) If iFieldNameLength > iLongest Then iLongest = iFieldNameLength End If Next GetLongestFieldName = iLongest End Function '======================================== Private Function GetKeyFieldIndex(iTableIndex,asTables, asFields) 'Looks for a unique identifier for deletes, gets, etc. 'At the moment, this looks for Type=Int, Status=Identity 'If that fails, it looks for a name suffix of ID 'It does NOT yet work properly for compound keys and gives up Dim iKeyFieldIndex, iFieldCount, iFieldIndex, sFieldName, sFieldType, sFieldStatus 'Dummy value for when we give up iKeyFieldIndex = -1 iFieldCount = asTables(iTableIndex,1) For iFieldIndex = 0 To iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) If (sFieldType = 56) AND (sFieldStatus = 128) Then iKeyFieldIndex = iFieldIndex Exit For End If Next 'If it failed try another strategy - fieldnames ending in 'ID' are a good candidate If iKeyFieldIndex = -1 Then For iFieldIndex = 0 To iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) If Right(sFieldName,2) = "ID" Then iKeyFieldIndex = iFieldIndex Exit For End If Next End If GetKeyFieldIndex = iKeyFieldIndex End Function '======================================== Private Function TranslateDataType(iDateType) 'These are all the datatypes I know about Select Case iDateType Case 034 TranslateDataType = "Image " Case 035 TranslateDataType = "Text " Case 036 TranslateDataType = "UniqueIdentifier" Case 048 TranslateDataType = "TinyInt " Case 052 TranslateDataType = "SmallInt " Case 056 TranslateDataType = "Int " Case 058 TranslateDataType = "SmallDatetime " Case 059 TranslateDataType = "Real " Case 060 TranslateDataType = "Money " Case 061 TranslateDataType = "Datetime " Case 062 TranslateDataType = "Float " Case 098 TranslateDataType = "Sql_Variant " Case 099 TranslateDataType = "nText " Case 104 TranslateDataType = "Bit " Case 106 TranslateDataType = "Decimal " Case 108 TranslateDataType = "Numeric " Case 122 TranslateDataType = "SmallMoney " Case 127 TranslateDataType = "BigInt " Case 165 TranslateDataType = "VarBinary " Case 167 TranslateDataType = "VarChar " Case 173 TranslateDataType = "Binary " Case 175 TranslateDataType = "Char " Case 189 TranslateDataType = "Timestamp " Case 231 TranslateDataType = "nVarChar " Case 231 TranslateDataType = "SysName " Case 239 TranslateDataType = "nChar " Case 241 TranslateDataType = "Xml " Case Else TranslateDataType = "Unknown Datatype" End Select End Function '======================================== Private Sub DataDump(oFile,iTableIndex,asTables,asFields) Dim iFieldCount,iFieldIndex,sFieldName,sFieldType,sFieldStatus,sFieldClass,sFieldTypeX,iPad iPad = GetLongestFieldName(iTableIndex,asTables,asFields) iFieldCount = asTables(iTableIndex,1) oFile.WriteLine("") oFile.WriteLine(vbTab & "'" & String(30,"-")) For iFieldIndex = 0 To iFieldCount-1 sFieldName = Left(asFields(iTableIndex,iFieldIndex,0) & Space(iPad), iPad) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) sFieldTypeX = TranslateDataType(sFieldType) oFile.WriteLine(vbTab & "'" & sFieldName & " - " & sFieldClass & " - " & sFieldTypeX & " - " & sFieldType & " - " & sFieldStatus) Next oFile.WriteLine(vbTab & "'" & String(30,"-")) oFile.WriteLine("") End Sub '======================================== Private Function GetParamUpdate(iTableIndex,asTables,asFields) 'This generates the parameter list for an Update Dim iFieldCount, iFieldIndex, sFieldName, sFieldType, sFieldStatus, sFieldClass, sParam, bSuppress sParam = "" iFieldCount = asTables(iTableIndex,1) For iFieldIndex = 0 To iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) bSuppress = False If sFieldClass = "x" Then 'Field type not handled bSuppress = True End If If NOT bSuppress Then sParam = sParam & sFieldClass & sFieldName & "," End If Next 'Remove comma on last parameter sParam = Left(sParam,Len(sParam)-1) GetParamUpdate = sParam End Function '======================================== Private Function GetParamAdd(iTableIndex,asTables,asFields) Dim iFieldCount, iFieldIndex, sFieldName, sFieldType, sFieldStatus, sFieldClass, sParam, bSuppress sParam = "" iFieldCount = asTables(iTableIndex,1) For iFieldIndex = 0 To iFieldCount-1 sFieldName = asFields(iTableIndex,iFieldIndex,0) sFieldType = asFields(iTableIndex,iFieldIndex,1) sFieldStatus = asFields(iTableIndex,iFieldIndex,2) sFieldClass = asFields(iTableIndex,iFieldIndex,3) bSuppress = False If (sFieldType = 56) And (sFieldStatus = 128) Then 'Identity field bSuppress = True End If If sFieldClass = "x" Then 'Field type not handled bSuppress = True End If If NOT bSuppress Then sParam = sParam & sFieldClass & sFieldName & "," End If Next 'Remove comma from last parameter sParam = Left(sParam,Len(sParam)-1) GetParamAdd = sParam End Function '========================================================================= |