Visual Basic Code , VB.NET Code
Find Code:
  All
  VB.NET
  ASP.NET
  C#
  VB Classic
  ASP Classic
  Snippets
  Popular
  Submit Code
  Forums
  Articles
  Tips
  Links
  Books
  Contest
  Link to us
 
 This is a compilation of functions I use when work...e-mail code snippet
Author: Devin Garlit
E-mail: Click to e-mail author
Submitted: 5/4/2001
Version: ASP
Compatibility: ASP
Category: ASP
Views: 22848
  Declarations:
  Code:
" buildTextArea = strTemp end function '************************************************************** 'Function: buildDropDownFromDB( objConnection, strSQL, strName) ' 'Returns: an string of an HTML checkbox ' 'Inputs: ' objConnection = a connection object ' strSQL = a string of a SQL statement ' strName = a string of the name attribute of the select box ' 'Notes: ' 'Programmer: Devin Garlit dgarlit@hotmail.com. 4/01/01 '************************************************************** function buildDropDownFromDB( objConnection, strSQL, strName) dim RS 'recordset dim strTemp set RS = objConnection.execute(strSQL) strTemp = "" buildDropDownFromDB = strTemp end function '************************************************************** 'Function: buildDropDownFromDBwithTitle( objConnection, strSQL, strName, strTitle) ' 'Returns: an string of an HTML checkbox ' 'Inputs: ' objConnection = a connection object ' strSQL = a string of a SQL statement ' strName = a string of the name attribute of the select box ' strTitle = a string for the value of the first option of the select box i.e. "Select" ' 'Notes: ' 'Programmer: Devin Garlit dgarlit@hotmail.com. 4/01/01 '************************************************************** function buildDropDownFromDBwithTitle( objConnection, strSQL, strName, strTitle) dim RS 'recordset dim strTemp set RS = objConnection.execute(strSQL) strTemp = "" buildDropDownFromDBwithTitle = strTemp end function '************************************************************** 'Function: createAForm(RS, strFormName, strFormMethod, strFormAction) ' 'Returns: creates a simple html form of text boxes using buildTextBox from a recordset ' 'Inputs: ' RS = a recordset object ' strFormName = a string of the name of the form ' strFormMethod = a string of the forms method i.e. "post" ' strFormAction = a string of the forms action ' 'Notes: real simple, just lines them up in a simple table and gives a simple submit button ' 'Programmer: Devin Garlit dgarlit@hotmail.com. 4/01/01 '************************************************************** function createAForm(RS, strFormName, strFormMethod, strFormAction) dim x Response.Write "" & vbcrlf Response.Write "" & vbcrlf for x = 0 to RS.Fields.Count-1 Response.Write "" & vbcrlf next Response.Write "" & vbcrlf Response.Write "
" Response.write RS.Fields(x).Name & "" Response.Write buildTextBox("", RS.Fields(x).Name, 25, RS.Fields(x).DefinedSize, false, "") & "
" Response.Write "
 
" & vbcrlf Response.Write "" end function function requestAndIncludeAsHidden() dim field for each Field in Request.Form buildHidden request(field), field.name, true, request(field) next end function 'a classic to take care of those pesky quotes when working with SQL function CheckQuotes(strValue) if not isnull(strValue) and strValue <> "" then CheckQuotes = replace(strValue,"'","''") else CheckQuotes = strValue end if end function ''''cachecontrol '''included right after option explicit 'Response.Buffer=TRUE 'Response.Expires = 0 'Response.AddHeader "Pragma","no-cache" 'Response.AddHeader "cache-control","no-store" 'capitilize first letter function Caps(strString) Caps = ucase(left(strString,1)) & lcase(mid(strString,2)) end function 'capitializ all words in a string 'write capAllWords("we actually do listen to our users once in a while") function capAllWords(strString) dim arrTemp, strTemp, i arrTemp = split(strString, " ") for i = 0 to Ubound(arrTemp) strTemp = strTemp & " " & ucase(left(arrTemp(i),1)) & lcase(mid(arrTemp(i),2)) next capAllWords = strTemp end function 'write GetYear("09/24/1977") 'return a simple year # from a string in format of yyyy function GetYear(strDate) GetYear = datepart("yyyy",strDate) end function 'return a month # function GetMonthNum(strDate) GetMonthNum = datepart("m",strDate) end function 'return a day # function GetDayNum(strDate) GetDayNum = datepart("d",strDate) end function 'return day and date like this: Saturday, September 24, 1977 function GetDateWithDay(strDate) GetDateWithDay = formatdatetime(strDate,1) end function 'return long date like 9/24/1977 function GetLongDate(strDate) GetLongDate = formatdatetime(strDate,2) end function 'returns a date from the month, day and year, allows an empty string for day( but will pull the first of the month 'write GetDateFromParts("9", "", "77") 'write GetDateFromParts("9", "24", "77") function GetDateFromParts(strMonth, strDay, strYear) if strDay <> "" then GetDateFromParts = formatdatetime(strMonth & "/" & strDay & "/" & strYear) else GetDateFromParts = formatdatetime(strMonth & "/" & strYear) end if end function ''''''''''' ''''vbs function FormatDateTime formats''' 'd Short Date 'D Long Date 'f Full (long date + short time) 'F Full (long date + long time) 'g General (short date + short time) 'G General (short date + long time) 'm, M Month/Day Date 'r, R RFC Standard 's Sortable without TimeZone info 't Short Time 'T Long Time 'u Universal with sort able format 'U Universal with Full (long date + long time) format 'y, Y Year/Month Date 'returns a true if the number (an int or string) is odd, a false otherwise function isOdd(strNum) if cint(strNum) mod 2 = 0 then isOdd = false else isOdd = true end if end function 'remove HTML tags from a string, note, this won't handle html encoding. 'write RemoveHTMLTags("BOB rules") Function RemoveHTMLTags(strString) Dim nCharPos, sOut, bInTag, sChar sOut = "" bInTag = False For nCharPos = 1 To Len(strString) sChar = Mid(strString, nCharPos, 1) If sChar = "<" Then bInTag = True End If If Not bInTag Then sOut = sOut & sChar If sChar = ">" Then bInTag = False End If Next RemoveHTMLTags = sOut End Function '''''''''''''''''''''''''''''''''''sortable table 'dim objConn 'Set objConn = server.CreateObject("ADODB.Connection") 'objConn.Open "passwordlist" 'strSQL = "Select * From passwords" 'createSortableList objConn,strSQL, "id", request("sort"),request("page"),"sort.asp",5, "border=1 bgcolor=steelblue" 'creates a sortable html table sub createSortableList(objConn,strSQL, strDefaultSort, strSort, intCurrentPage, strPageName, intPageSize, strLinkedColumnName,strLink,strTableAttributes) dim RS 'recordset dim strTemp, field, strMoveFirst, strMoveNext, strMovePrevious, strMoveLast dim i, intTotalPages, intCurrentRecord, intTotalRecords i = 0 if strSort = "" then strSort = strDefaultSort end if if intCurrentPage = "" then intCurrentPage = 1 end if set RS = server.CreateObject("adodb.recordset") with RS .CursorLocation=3 .Open strSQL & " order by " & replace(strSort,"desc"," desc"), objConn,adOpenStatic if not rs.EOF then .PageSize = cint(intPageSize) intTotalPages = .PageCount intCurrentRecord = .AbsolutePosition .AbsolutePage = intCurrentPage intTotalRecords = .RecordCount end if end with Response.Write "" & vbcrlf Response.Write "" & vbcrlf 'if not rs.EOF then for each field in RS.Fields Response.Write "" for i = intCurrentRecord to RS.PageSize if not RS.eof then Response.Write "" & vbcrlf for each field in RS.Fields Response.Write "" & vbcrlf RS.MoveNext end if next Response.Write "
" & vbcrlf if instr(strSort, "desc") then Response.Write "" & field.name & "" & vbcrlf else Response.Write "" & field.name & "" & vbcrlf end if Response.Write "" & vbcrlf next 'end if Response.Write "
" & vbcrlf if lcase(strLinkedColumnName) = lcase(field.name) then Response.Write "" & field.value & "" & vbcrlf else Response.Write field.value end if Response.Write "" & vbcrlf next Response.Write "
" & vbcrlf 'Response.Write intTotalPages & " " & intCurrentPage select case cint(intCurrentPage) case cint(intTotalPages) 'last page strMoveFirst = ""& "first" &"" strMoveNext = "" strMovePrevious = ""& "Prev" &"" strMoveLast = "" '"" case 1 'first page strMoveFirst = "" '"" strMoveNext = ""& "next" &"" strMovePrevious = "" '"" strMoveLast = ""& "last" &"" case else strMoveFirst = ""& "first" &"" strMoveNext = ""& "next" &"" strMovePrevious = ""& "Prev" &"" strMoveLast = ""& "last" &"" end select with Response .Write strMoveFirst & " " .Write strMovePrevious .Write " " & intCurrentPage & " of " & intTotalPages & " " .Write strMoveNext & " " .Write strMoveLast end with if RS.State = &H00000001 then 'its open RS.Close end if set RS = nothing end sub '************************************************************** 'Function: writeTable(intCols, intRows, strTableAttributes, strRowAttributes, arrValues) ' 'Returns: writes a html table ' 'Inputs: ' intCols = # of column ' intRows = # of rows ' strTableAttributes = string of table attributes seperated by a space i.e. "border=1 bgcolor=steelblue" ' strRowAttriutes = string of row attributes seperated by a space i.e. "valign=top" ' arrValues = a multidimensional array in format of arr(rows,cols) ' 'Notes: ' 'Programmer: Devin Garlit dgarlit@hotmail.com. 4/01/01 '************************************************************** function writeTable(intCols, intRows, arrValues, strTableAttributes, strRowAttributes, strCellAttributes ) dim i, j write "
" & vbcrlf for i = 0 to intRows - 1 write "" & vbcrlf for j = 0 to intCols - 1 write "" & vbcrlf next write "" & vbcrlf next write "
" & vbcrlf write arrValues(i,j) write "
" & vbcrlf end function function writeTable2(arrValues, strTableAttributes, strRowAttributes, strCellAttributes ) dim i, j 'write ubound(arrValues,1) 'write ubound(arrValues,1) 'Response.end write "" & vbcrlf for i = 0 to ubound(arrValues)-1 write "" & vbcrlf for j = 0 to ubound(arrValues,1)-1 write "" & vbcrlf next write "" & vbcrlf next write "
" & vbcrlf write arrValues(i,j) write "
" & vbcrlf end function '************************************************************** 'Function: createAForm2WHidden(RS, strFormName, strFormMethod, strFormAction, strButton) ' 'Returns: creates a simple html form of hidden fields from a recordset ' 'Inputs: ' RS = a recordset object ' intColumnSplit = the number at which to stop the first column, the rest of the fields will go to the next ' strFormName = a string of the name of the form ' strFormMethod = a string of the forms method i.e. "post" ' strFormAction = a string of the forms action ' strButton = a string of html for the submit and other action type buttons ' 'Notes: real simple, just lines them up in a simple table and gives a simple submit button ' 'Programmer: Devin Garlit dgarlit@hotmail.com. 4/01/01 '************************************************************** function createAForm2WHidden(RS, intColumnSplit, strFormName, strFormMethod, strFormAction, strButton) dim x write "
" & vbcrlf write "" & vbcrlf write "" & vbcrlf write "" write "" & vbcrlf write "" & vbcrlf write "
" & vbcrlf write "" & vbcrlf for x = 0 to intColumnSplit write "" & vbcrlf next write "
" & vbcrlf write RS.Fields(x).Name & "" write buildHidden(request(cstr(RS.Fields(x).Name)), RS.Fields(x).Name,true, request(cstr(RS.Fields(x).Name)) ) write "
" & vbcrlf write "
" write "" & vbcrlf for x = intColumnSplit + 1 to RS.Fields.Count-1 write "" & vbcrlf next write "
" & vbcrlf write RS.Fields(x).Name & "" write buildHidden(request(cstr(RS.Fields(x).Name)), RS.Fields(x).Name,true, request(cstr(RS.Fields(x).Name)) ) write "
" & vbcrlf write "
" & vbcrlf write strButton & vbcrlf write "
" end function '************************************************************** 'Function: createAForm2(RS, intColumnSplit, strFormName, strFormMethod, strFormAction, strButton, strEditFlag) ' 'Returns: creates a simple html form of hidden fields from a recordset ' 'Inputs: ' RS = a recordset object ' intColumnSplit = the number at which to stop the first column, the rest of the fields will go to the next ' strFormName = a string of the name of the form ' strFormMethod = a string of the forms method i.e. "post" ' strFormAction = a string of the forms action ' strButton = a string of html for the submit and other action type buttons ' strEditFlag = a string of whether to fill the txtboxes with requested false, true or false ' 'Notes: real simple, just lines them up in a simple table and gives a simple submit button ' 'Programmer: Devin Garlit dgarlit@hotmail.com. 4/01/01 '************************************************************** function createAForm2(RS, intColumnSplit, strFormName, strFormMethod, strFormAction, strButton, strEditFlag) dim x write "
" & vbcrlf write "" & vbcrlf write "" & vbcrlf write "" write "" & vbcrlf write "" & vbcrlf write "
" & vbcrlf write "" & vbcrlf for x = 0 to intColumnSplit write "" & vbcrlf next write "
" & vbcrlf write RS.Fields(x).Name & "" if cbool(strEditFlag) then write buildTextBox(request(cstr(RS.Fields(x).Name)), RS.Fields(x).Name, 25, RS.Fields(x).DefinedSize, false, "") & "
" else write buildTextBox("", RS.Fields(x).Name, 25, RS.Fields(x).DefinedSize, false, "") & "
" end if write "
" & vbcrlf write "
" write "" & vbcrlf for x = intColumnSplit + 1 to RS.Fields.Count-1 write "" & vbcrlf next write "
" & vbcrlf write RS.Fields(x).Name & "" if cbool(strEditFlag) then write buildTextBox(request(cstr(RS.Fields(x).Name)), RS.Fields(x).Name, 25, RS.Fields(x).DefinedSize, false, "") & "
" else write buildTextBox("", RS.Fields(x).Name, 25, RS.Fields(x).DefinedSize, false, "") & "
" end if write "
" & vbcrlf write "
" & vbcrlf write strButton & vbcrlf write "
" end function function getDaysInMonth(strMonth,strYear) dim strDays Select Case cint(strMonth) Case 1,3,5,7,8,10,12: strDays = 31 Case 4,6,9,11: strDays = 30 Case 2: if ( (cint(strYear) mod 4 = 0 and cint(strYear) mod 100 <> 0) or ( cint(strYear) mod 400 = 0) ) then strDays = 29 else strDays = 28 end if 'Case Else: End Select getDaysInMonth = strDays end function '''writeDropDowns is a way I used MonthDropDown, DayDropDown, and YearDropDown together 'basically, the point was that I didn't want someone to select 30 for the month of february 'so it resubmits to the page(that could be costly depending on what else is goin on) with the selected 'day,month,year and it sets/resets the days according to the month and year so the user cannot select 'day 30 for month 2 sub writeDropDowns() dim strSelfLink strSelfLink = "InvoiceList.asp?sort=" & request("sort") & "&page=" & request("page") write "
" & vbcrlf write MonthDropDown("month1",true,request("month1"),strSelfLink) & " " & DayDropDown("day1", "",getDaysInMonth(request("month1"),request("year1")),request("day1")) & " " & YearDropDown("year1","","", request("year1"),strSelfLink) & _ " To " & MonthDropDown("month2",true, request("month2"),strSelfLink) & " " & DayDropDown("day2", "",getDaysInMonth(request("month2"),request("year2")),request("day2")) & " " & YearDropDown("year2","","", request("year2"),strSelfLink) & vbcrlf write "Submit" write "
" & vbcrlf end sub 'write MonthDropDown("Month1",true) function MonthDropDown(strName, blnNum, strSelected, strSelfLink) 'if blnNUM is true, then show as numbers dim strTemp, i, strSelectedString strTemp = "" & vbcrlf MonthDropDown = strTemp end function 'write YearDropDown("Year1", 2001, 2010) function YearDropDown(strName, intStartYear, intEndYear, strSelected, strSelfLink) dim strTemp, i, strSelectedString if intStartYear = "" then intStartYear = Year(now()) end if if intEndYear = "" then intEndYear = Year(now()) + 9 end if strTemp = "" & vbcrlf YearDropDown = strTemp end function 'write DayDropDown("Day1",1,getDaysInMonth(2,2001) ) function DayDropDown(strName, intStartDay, intEndDay, strSelected ) dim strTemp, i, strSelectedString if intStartDay = "" then intStartDay = 1 end if if intEndDay = "" then intEndDay = getDaysInMonth(Month(now()),Year(now())) end if strTemp = "" & vbcrlf DayDropDown = strTemp end function sub beginDoc(strTitle) write "" & vbcrlf write "" & vbcrlf write "" & strTitle & "" & vbcrlf write "" & vbcrlf write "" & vbcrlf end sub sub endDoc() write "" & vbcrlf write "" & vbcrlf end sub Const KERMITTHEFROGGREEN = "#beff43" %>