FWIW, the code below is what I use to generate ASP page shells for me.
It's not perfect, but it does a lot of the typing and generates an FETCH,
INSERT and UPDATE function, as well as drawing the text boxes.
Watch for line wrap. If it doesn't come through, write me at the email
below and I'll send it to you in a zipped mdb format.
--
Danny J. Lesandrini
dl*********@hotmail.com http://amazecreations.com/datafast
Option Compare Database
Option Explicit
Function WriteASP(ByVal sTable As String) As Boolean
On Error GoTo Err_Handler
Dim sASP As String
Dim sSQL As String
Dim sDBName As String
Dim q As String
Dim t As String
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim prp As DAO.Property
Dim sField As String
Dim sCaption As String
Dim sCtl As String
Dim sCtlRef As String
Dim sHidden As String
Dim intSize As Integer
Dim sVariables As String
Dim sVar As String
Dim sInsertVal As String
Dim sForm As String
Dim sIDCheck As String
Dim sAssignments As String
Dim sPost As String
Dim sStart As String
Dim sMid As String
Dim sClose As String
Dim sInput As String
Dim sFile As String
Dim sPath As String
Dim sINSERT As String
Dim sINSArgList As String
Dim sINSValues As String
Dim sUPDValues As String
Dim sUPDATE As String
Dim sUPDWhere As String
Dim sDelim As String
Dim sFetch As String
Dim sRecords As String
Dim sFetchSQL As String
Dim fPK As Boolean
Dim sSampleLink As String
' Execute example
' ?WriteASP("tblProgram")
Set dbs = CurrentDb
Set tdf = dbs.TableDefs(sTable)
sDBName = Right(dbs.Name, Len(dbs.Name) - LastInStr(dbs.Name, "\"))
q = """"
t = " "
sPath = Left(CurrentDb.Name, LastInStr(CurrentDb.Name, "\"))
'sFile = sPath & sTable & ".txt"
sFile = sPath & sTable & ".asp"
If Len(Dir(sFile)) > 0 Then Kill sFile
sVariables = "<%" & vbCrLf & t & "Dim varID, "
sStart = t & t & "<tr valign=" & q & "top" & q & "><td width=" & q & 150 & q & "> "
sMid = t & t & "</td><td width=" & q & 255 & q & "> " & vbCrLf
sClose = t & t & "</td></tr>" & vbCrLf
sInput = t & t & t & "<INPUT style=" & q & "FONT-SIZE: xx-small; WIDTH: "
sINSArgList = t & t & "sSQL = " & q & "INSERT INTO " & sTable & " ("
sINSValues = t & t & "sSQL = sSQL & " & q & " VALUES("
sUPDValues = t & t & "sSQL = " & q & "UPDATE " & sTable & " SET " & q & vbCrLf
sIDCheck = ""
sForm = "<FORM method=post action=" & sTable & ".asp?ID=<%=varID%> id=frm" & sTable & " name=frm" & sTable & ">" &
vbCrLf & vbCrLf
sForm = sForm & "<INPUT type=submit value=Save id=btnSave name=btnSave>" & vbCrLf & vbCrLf
sASP = t & "<table border=" & q & "1" & q & " width=" & q & "100%" & q & " id=" & q & sTable & q & ">" & vbCrLf
On Error Resume Next
For Each fld In tdf.Fields
sField = fld.Name
If sField = "OfficialCKSchool" Then
Beep
End If
sCaption = fld.Properties("Caption")
sVar = "var" & sField
sCtl = "txt" & sField
sDelim = GetFieldDeliminator(fld.Type)
intSize = fld.Size
sCtlRef = "Request.Form(" & q & sCtl & q & ")"
If sCaption = "" Then sCaption = sField
If intSize < 25 Then intSize = 25
If (fld.Attributes And dbAutoIncrField) Then fPK = True Else fPK = False
If fPK Then
sFetchSQL = t & "sSQL = " & q & "SELECT * FROM " & sTable & " WHERE " & sField & " = " & q & " & varID"
sSampleLink = t & "<a href=" & sTable & ".asp?ID=" & DMax(fld.Name, sTable) & ">Go To Sample Record</a>"
End If
If sCaption <> "AutoNumber" Then
If sDelim = "'" Then
' Replace single quotes with two single quotes so SQL statement doesn't break
' Truncate user response to size limit of field, to avoid INSERT/UPDATE error.
sInsertVal = "Left(Replace(" & sVar & "," & q & "'" & q & "," & q & "''" & q & ")," & fld.Size & ")"
Else
sInsertVal = sVar
End If
If Not fPK Then
sINSArgList = sINSArgList & sField & ","
sINSValues = sINSValues & sDelim & q & " & " & sInsertVal & " & " & q & sDelim & ","
sUPDValues = sUPDValues & t & t & "sSQL = sSQL & " & q & sField & "=" & sDelim & q & " & " & sInsertVal
& " & " & q & sDelim & "," & q & vbCrLf
End If
sHidden = ""
sRecords = sRecords & t & t & t & sVar & "=rsDataTable(" & q & sField & q & ")" & vbCrLf
Else
sCaption = vbCrLf & t & t & t & "<INPUT type=" & q & "submit" & q & " value=" & q & "Save" & q & " id=" & q
& "btnSave" & q & " name=" & q & "btnSave" & q & ">" & vbCrLf
sUPDWhere = t & t & "sSQL = sSQL & " & q & " WHERE " & sField & " = " & q & " & varID" & vbCrLf
sHidden = " Type=" & q & "hidden" & q
End If
sVariables = sVariables & sVar & ","
sAssignments = sAssignments & t & sVar & " = " & sCtlRef & vbCrLf
sASP = sASP & sStart & sCaption & vbCrLf
sASP = sASP & sMid & sInput & intSize & "px" & q
sASP = sASP & " id=" & q & "txt" & sField & q & _
" name=" & q & "txt" & sField & q & _
" value=" & q & "<%=Trim(" & sVar & ")%>" & q
sASP = sASP & sHidden & ">" & vbCrLf & sClose & vbCrLf
' Reset variables
sCaption = ""
Next
sFetch = vbCrLf
sFetch = sFetch & t & "Function RetrieveRecord(varID)" & vbCrLf
sFetch = sFetch & t & t & "Dim sSQL, sPath, sConn, cnnDBS, rsDataTable" & vbCrLf & vbCrLf
sFetch = sFetch & t & t & "Set cnnDBS = server.CreateObject(" & q & "adodb.connection" & q & ")" & vbCrLf
sFetch = sFetch & t & t & "sPath = LCase(Server.MapPath(" & q & sTable & ".asp" & q & "))" & vbCrLf
sFetch = sFetch & t & t & "sPath = Replace(sPath, " & q & LCase(sTable) & ".asp" & q & ", " & q & sDBName & q & ")"
& vbCrLf
sFetch = sFetch & t & t & "sConn = " & q & "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data
Source=" & q & " & sPath" & vbCrLf
sFetch = sFetch & t & t & "cnnDBS.Open (sConn)" & vbCrLf & vbCrLf
sFetch = sFetch & t & t & "Set rsDataTable = server.CreateObject(" & q & "adodb.recordset" & q & ")" & vbCrLf
sFetch = sFetch & t & t & sFetchSQL & vbCrLf
sFetch = sFetch & t & t & "Set rsDataTable = cnnDBS.Execute(sSQL)" & vbCrLf & vbCrLf
sFetch = sFetch & t & t & "If Not rsDataTable.BOF And Not rsDataTable.EOF Then" & vbCrLf
sFetch = sFetch & sRecords & vbCrLf
sFetch = sFetch & t & t & "End If" & vbCrLf
sFetch = sFetch & t & t & "Set rsDataTable = Nothing" & vbCrLf
sFetch = sFetch & t & t & "Set cnnDBS = Nothing" & vbCrLf & vbCrLf
sFetch = sFetch & t & "End Function" & vbCrLf
sPost = sPost & vbCrLf
sPost = sPost & t & "varID = Request.QueryString(" & q & "ID" & q & ")" & vbCrLf
sPost = sPost & t & "If varID = " & q & q & " Then varID = " & q & "0" & q & vbCrLf & vbCrLf
sPost = sPost & t & "If Request(" & q & "btnSave" & q & ") <> " & q & q & " Then" & vbCrLf
sPost = sPost & t & t & "If varID = " & q & "0" & q & " Then" & vbCrLf
sPost = sPost & t & t & t & "varID = InsertNewRecord()" & vbCrLf
sPost = sPost & t & t & "Else" & vbCrLf
sPost = sPost & t & t & t & "Call UpdateRecord(varID)" & vbCrLf
sPost = sPost & t & t & "End If" & vbCrLf
sPost = sPost & t & "Else" & vbCrLf
sPost = sPost & t & t & "Call RetrieveRecord(varID)" & vbCrLf
sPost = sPost & t & "End If" & vbCrLf & vbCrLf
sINSArgList = Left(sINSArgList, Len(sINSArgList) - 1) & ") " & q & vbCrLf
sINSValues = Left(sINSValues, Len(sINSValues) - 1) & ") " & q & vbCrLf
sINSERT = t & "Function InsertNewRecord()" & vbCrLf
sINSERT = sINSERT & t & t & "Dim sSQL, varID, sPath, sConn, cnnDBS, rsDataTable" & vbCrLf & vbCrLf
sINSERT = sINSERT & t & t & "Set cnnDBS = server.CreateObject(" & q & "adodb.connection" & q & ")" & vbCrLf
sINSERT = sINSERT & t & t & "sPath = LCase(Server.MapPath(" & q & sTable & ".asp" & q & "))" & vbCrLf
sINSERT = sINSERT & t & t & "sPath = Replace(sPath, " & q & LCase(sTable) & ".asp" & q & ", " & q & sDBName & q &
")" & vbCrLf
sINSERT = sINSERT & t & t & "sConn = " & q & "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data
Source=" & q & " & sPath" & vbCrLf
sINSERT = sINSERT & t & t & "cnnDBS.Open (sConn)" & vbCrLf & vbCrLf
sINSERT = sINSERT & sINSArgList & sINSValues & vbCrLf
sINSERT = sINSERT & t & t & "sSQL = Replace(sSQL," & q & "'Null'" & q & "," & q & "Null" & q & ")" & vbCrLf
sINSERT = sINSERT & t & t & "sSQL = Replace(sSQL," & q & ",," & q & "," & q & ",Null," & q & ")" & vbCrLf
sINSERT = sINSERT & t & t & "sSQL = Replace(sSQL," & q & ",," & q & "," & q & ",Null," & q & ")" & vbCrLf
sINSERT = sINSERT & t & t & "cnnDBS.Execute (sSQL)" & vbCrLf & vbCrLf
sINSERT = sINSERT & t & t & "sSQL = " & q & "SELECT Max([SchlID]) As ID FROM " & sTable & q & vbCrLf
sINSERT = sINSERT & t & t & "Set rsDataTable = server.CreateObject(" & q & "adodb.recordset" & q & ") " & vbCrLf
sINSERT = sINSERT & t & t & "Set rsDataTable = cnnDBS.Execute(sSQL)" & vbCrLf
sINSERT = sINSERT & t & t & "InsertNewRecord = rsDataTable(" & q & "ID" & q & ")" & vbCrLf & vbCrLf
sINSERT = sINSERT & t & t & "If rsDataTable.BOF And rsDataTable.EOF Then" & vbCrLf
sINSERT = sINSERT & t & t & t & "InsertNewRecord = 0" & vbCrLf
sINSERT = sINSERT & t & t & "Else" & vbCrLf
sINSERT = sINSERT & t & t & t & "InsertNewRecord = rsDataTable(" & q & "ID" & q & ")" & vbCrLf
sINSERT = sINSERT & t & t & "End If" & vbCrLf & vbCrLf
sINSERT = sINSERT & t & t & "Set rsDataTable = Nothing" & vbCrLf
sINSERT = sINSERT & t & t & "Set cnnDBS = Nothing" & vbCrLf & vbCrLf
sINSERT = sINSERT & t & "End Function" & vbCrLf
sUPDValues = Left(sUPDValues, Len(sUPDValues) - 4) & q & vbCrLf
sUPDValues = sUPDValues & sUPDWhere & vbCrLf
sUPDATE = t & "Function UpdateRecord(varID)" & vbCrLf
sUPDATE = sUPDATE & t & t & "Dim sSQL, sPath, sConn, cnnDBS" & vbCrLf & vbCrLf
sUPDATE = sUPDATE & t & t & "Set cnnDBS = server.CreateObject(" & q & "adodb.connection" & q & ")" & vbCrLf
sUPDATE = sUPDATE & t & t & "sPath = LCase(Server.MapPath(" & q & sTable & ".asp" & q & "))" & vbCrLf
sUPDATE = sUPDATE & t & t & "sPath = Replace(sPath, " & q & LCase(sTable) & ".asp" & q & ", " & q & sDBName & q &
")" & vbCrLf
sUPDATE = sUPDATE & t & t & "sConn = " & q & "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data
Source=" & q & " & sPath" & vbCrLf
sUPDATE = sUPDATE & t & t & "cnnDBS.Open (sConn)" & vbCrLf & vbCrLf
sUPDATE = sUPDATE & sUPDValues & vbCrLf
'sUPDATE = sUPDATE & t & t & "sSQL = Replace(sSQL," & q & "''" & q & "," & q & "Null" & q & ")" & vbCrLf
sUPDATE = sUPDATE & t & t & "sSQL = Replace(sSQL," & q & "=''" & q & "," & q & "=Null" & q & ")" & vbCrLf
sUPDATE = sUPDATE & t & t & "sSQL = Replace(sSQL," & q & "=," & q & "," & q & "=Null," & q & ")" & vbCrLf
sUPDATE = sUPDATE & t & t & "cnnDBS.Execute (sSQL)" & vbCrLf & vbCrLf
sUPDATE = sUPDATE & t & t & "Set cnnDBS = Nothing" & vbCrLf & vbCrLf
sUPDATE = sUPDATE & t & "End Function" & vbCrLf
sVariables = Left(sVariables, Len(sVariables) - 1) & vbCrLf & vbCrLf
sAssignments = sAssignments & vbCrLf & vbCrLf
sPost = sPost & vbCrLf & vbCrLf & "%>" & vbCrLf & vbCrLf
sASP = sVariables & sAssignments & sPost & sForm & sASP & t & "</table>" & vbCrLf & vbCrLf & "<%" & vbCrLf & vbCrLf
sASP = sASP & sINSERT & vbCrLf & sUPDATE & vbCrLf & sFetch & vbCrLf & "%>" & vbCrLf & vbCrLf & "</FORM>" & vbCrLf
Set tdf = Nothing
Set dbs = Nothing
WriteASP = (Err.Number = 0)
sASP = "<br>" & sSampleLink & "<br><br>" & sASP
WriteToFile sFile, sASP
Shell "Notepad.exe " & sFile, vbNormalFocus
Exit Function
Err_Handler:
MsgBox Err.Description
Resume Next
End Function
Function GetFieldDeliminator(ByVal intFieldType As Integer) As String
On Error Resume Next
Select Case intFieldType
Case dbBigInt: GetFieldDeliminator = ""
Case dbBinary: GetFieldDeliminator = ""
Case dbBoolean: GetFieldDeliminator = ""
Case dbByte: GetFieldDeliminator = ""
Case dbChar: GetFieldDeliminator = "'"
Case dbCurrency: GetFieldDeliminator = ""
Case dbDate: GetFieldDeliminator = "#"
Case dbDecimal: GetFieldDeliminator = ""
Case dbDouble: GetFieldDeliminator = ""
Case dbFloat: GetFieldDeliminator = ""
Case dbGUID: GetFieldDeliminator = "'"
Case dbInteger: GetFieldDeliminator = ""
Case dbLong: GetFieldDeliminator = ""
Case dbLongBinary: GetFieldDeliminator = ""
Case dbMemo: GetFieldDeliminator = "'"
Case dbNumeric: GetFieldDeliminator = ""
Case dbSingle: GetFieldDeliminator = ""
Case dbText: GetFieldDeliminator = "'"
Case dbTime: GetFieldDeliminator = "#"
Case dbTimeStamp: GetFieldDeliminator = ""
Case dbVarBinary: GetFieldDeliminator = ""
End Select
End Function
Function WriteToFile(ByVal sFile As String, ByVal sText As String)
On Error Resume Next
Dim intFileNum As Integer
intFileNum = FreeFile
Open sFile For Append Shared As intFileNum
Print #intFileNum, sText
Close #intFileNum
End Function
Function LastInStr(sSearched As String, sSought As String) As Integer
On Error Resume Next
'//////////////////////////////////////////////////////////////////////////
'
' This function finds the last instance of a character within
' a String of characters and returns an integer representing
' the final position of the desired character.
'
' Typically, this function us used to find the final "\" in
' a file path String
'
'//////////////////////////////////////////////////////////////////////////
Dim intCurrVal As Integer
Dim intLastPosition As Integer
intCurrVal = InStr(sSearched, sSought)
Do Until intCurrVal = 0
intLastPosition = intCurrVal
intCurrVal = InStr(intLastPosition + 1, sSearched, sSought)
Loop
LastInStr = intLastPosition
End Function