Created
May 26, 2013 22:21
-
-
Save akitaonrails/5654223 to your computer and use it in GitHub Desktop.
Trechos de código que escrevi no ano 2000/2001 para ASP Classic inspirado no recém-lançado ASP.NET WebForms
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
<% | |
' | |
' This is the required interface that every element must implement | |
' in order to be usable by the global Page Class | |
' - Parent, Name, Value, IsType properties and required elements | |
' - Serialize, SetProperty and Render are required methods | |
' | |
Class Element | |
' type of this object | |
Property Get IsType : IsType = "object" : End Property | |
' the required name of the object | |
Property Get Parent : End Property | |
Property Let Parent( ByRef refObj ) : End Property | |
' get/set required name for this element | |
Property Get Name : End Property | |
Property Let Name ( str ) : End Property | |
' get/set required name for this element | |
Property Get Value : End Property | |
Property Let Value ( str ) : End Property | |
' set a particular optional event: gets a function reference | |
Property Let OnEvent( ByRef funcRef ) : End Property | |
' handles all events: called by the Page class | |
Public Sub EventHandler( sender, arguments ) | |
If Not IsNull( evtEvent ) Then | |
Call evtEvent( sender, arguments ) | |
End If | |
End Sub | |
' serializes the properties of this element in a XML structure like: | |
' <element id="name"> | |
' <propertyname>value</propertyname> | |
' </element> | |
Public Function Serialize | |
End Function | |
' called by the parent Page class and must be able to set | |
' all of it´s own properties | |
Public Sub SetProperty( name, value ) | |
End Sub | |
' renders the HTML control in the page | |
Public Sub Render | |
End Sub | |
Private Sub Class_Initialize | |
End Sub | |
Private Sub Class_Terminate | |
End Sub | |
End Class | |
%> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
<% | |
' | |
' Encapsulates all the functionallity of a Page/Form | |
' - wraps the Request object and Form elements handling | |
' | |
Class Page | |
Private objQueue | |
Private objEncoders | |
Private objBase64 | |
Private objForm | |
Private objValidator | |
Private strPost | |
Private strFormName | |
Private strSavePath | |
Private strJSMD5Path | |
Private boolEncode | |
Private boolHashPassword | |
Private childDelimiter | |
Private childNodeDelimiter | |
Private childValueDelimiter | |
Private evtLoad | |
Private evtInit | |
Private evtTerminate | |
Private evtFileUpload ' must expects a reference to the files collection | |
Private boolEvtLoad | |
Private boolEvtInit | |
Private boolEvtTerminate | |
Private boolEvtFileUpload ' must expects a reference to the files collection | |
' constructor - gets the submitted form elements and initialize vital objects | |
Private Sub Class_Initialize | |
childDelimiter = "<br />" | |
childNodeDelimiter = "&" | |
childValueDelimiter = "=" | |
strSavePath = "undefined" | |
strJSMD5Path = "md5.js" | |
boolHashPassword = True | |
boolEvtLoad = False | |
boolEvtInit = False | |
boolEvtTerminate = False | |
boolEvtFileUpload = False | |
Set objQueue = Server.CreateObject( "Scripting.Dictionary" ) | |
Set objEncoders = Server.CreateObject( "Encoders" ) | |
Set objBase64 = objEncoders.CreateInstance( "base64" ) | |
strPost = "" | |
If Request.TotalBytes > 0 Then | |
Set objForm = New clsUpload | |
' correct the last character broken by the clsUpload class | |
strPost = objForm.Form.Item( "_VIEWSTATE" ) | |
If Not IsEmpty( strPost ) Then | |
'strPost = Left( strPost, Len( strPost ) - 2 ) & "=" | |
strPost = objBase64.Decode( strPost ) | |
End If | |
End If | |
End Sub | |
' destructor - clean up | |
Private Sub Class_Terminate | |
Set objBase64 = Nothing | |
Set objQueue = Nothing | |
Set objForm = Nothing | |
End Sub | |
' set the OnLoad event handler | |
Public Property Let OnLoad( ByRef subRef ) : Set evtLoad = subRef : boolEvtLoad = True : End Property | |
' set the OnInit event handler | |
Public Property Let OnInit( ByRef subRef ) : Set evtInit = subRef : boolEvtInit = True : End Property | |
' set the OnTerminate event handler | |
Public Property Let OnTerminate( ByRef subRef ) : Set evtTerminate = subRef : boolEvtTerminate = True : End Property | |
' set the OnTerminate event handler | |
Public Property Let OnFileUpload( ByRef subRef ) : Set evtFileUpload = subRef : boolEvtFileUpload = True : End Property | |
' get/set the form name | |
Public Property Get FormName : FormName = strFormName : End Property | |
Public Property Let FormName( str ) : strFormName = str : End Property | |
' get the form collection | |
Public Property Get Form : Set Form = objForm : End Property | |
' get the postedchallenge collection | |
Public Property Get ChallengeSeed | |
ChallengeSeed = "" | |
If IsPostBack Then | |
ChallengeSeed = objForm.Form.Item( "_CHALLENGE" ) | |
End If | |
End Property | |
' get/set the path of the client side md5 script | |
Public Property Get MD5Path : MD5Path = strJSMD5Path : End Property | |
Public Property Let MD5Path( str ) : strJSMD5Path = str : End Property | |
' set validator container | |
Public Property Get Validator : Set Validator = objValidator : End Property | |
Public Property Let Validator( ByRef obj ) | |
Set objValidator = obj | |
objValidator.Parent = Me | |
End Property | |
' check all the registered validators | |
Public Property Get IsValid | |
IsValid = False | |
If Not IsNull( objValidator ) Then | |
IsValid = objValidator.IsValid | |
End If | |
End Property | |
' choose to transport hashed version of the password instead of plain-text | |
Public Property Get HidePassword : HidePassword = boolHashPassword : End Property | |
Public Property Let HidePassword( bool ) | |
If bool Then | |
boolHashPassword = True | |
Else | |
boolHashPassword = False | |
End If | |
End Property | |
' choose to make a binary encoded form for uploads | |
Public Property Get AllowUpload : AllowUpload = boolEncode : End Property | |
Public Property Let AllowUpload( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolEncode = True | |
Else | |
boolEncode = False | |
End If | |
End Property | |
' get/set the uploaded files saving location | |
Public Property Get UploadPath : UploadPath = strSavePath : End Property | |
Public Property Let UploadPath( str ) : strSavePath = str : End Property | |
' check if this is a form post back (result of a previous submit) | |
Public Property Get IsPostBack | |
If strPost <> "" Then | |
IsPostBack = True | |
Else | |
IsPostBack = False | |
End If | |
End Property | |
' cancel deserialization and other post back event operation | |
Public Sub CancelPostBack | |
strPost = "" | |
End Sub | |
' function called by the child objects | |
Public Function ChildSerializeNode( sName, sValue ) | |
ChildSerializeNode = childNodeDelimiter & sName & childValueDelimiter & Server.URLEncode( sValue ) | |
End Function | |
' persists all the elements currently registered objects | |
Private Function Serialize | |
Dim strResult, objTmp | |
For Each sElement in objQueue | |
Set objTmp = objQueue.Item( sElement ) | |
strResult = strResult & objTmp.Serialize() & childDelimiter | |
Next | |
' serialize the form´s own properties | |
strResult = strResult & _ | |
ChildSerializeNode( "name", strFormName ) & _ | |
ChildSerializeNode( "path", strSavePath ) & _ | |
ChildSerializeNode( "hidepwd", boolHashPassword ) & _ | |
ChildSerializeNode( "encode", boolEncode ) | |
Serialize = objBase64.Encode( strResult ) | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
FormName = strArg | |
Case "path" | |
UploadPath = strArg | |
Case "hidepwd" | |
HidePassword = strArg | |
Case "encode" | |
AllowUpload = strArg | |
End Select | |
End Sub | |
' adds a new form elements | |
Public Sub Add( ByRef oElement, strName ) | |
If Not objQueue.Exists( strName ) and strName <> "" Then | |
objQueue.Add strName, oElement | |
oElement.Name = strName | |
oElement.Parent = Me | |
End If | |
End Sub | |
' returns an element based on it´s name | |
Public Function Item( strName ) | |
If objQueue.Exists( strName ) Then | |
Set Item = objQueue( strName ) | |
End If | |
End Function | |
' loads the elements with the previous stored persistent data | |
' and trigger the current event | |
Public Sub Load | |
' call the event handler | |
If boolEvtInit Then | |
on error resume next | |
Call evtInit | |
on error goto 0 | |
End If | |
Dim oList, oElement, intCount, intSub | |
oList = Split( strPost, childDelimiter ) | |
If Not IsArray( oList ) Then | |
Exit Sub | |
End If | |
' iterate thru all the returned objects and deserialize them | |
For intCount = 0 To UBound( oList ) | |
oList( intCount ) = Split( oList( intCount ), "&" ) | |
' check if the element had persisted data posted back | |
If IsArray( oList( intCount ) ) Then | |
If objQueue.Exists( oList( intCount )( 0 ) ) Then | |
' if yes then iterates thru all it´s properties | |
For intSub = 1 To UBound( oList( intCount ) ) | |
oElement = Split( oList( intCount )( intSub ), "=" ) | |
If IsArray( oElement ) Then | |
If UBound( oElement ) = 1 Then | |
Call objQueue.Item( oList( intCount )( 0 ) ).SetProperty( oElement( 0 ), objForm.URLDecode( oElement( 1 ) ) ) | |
End If | |
End If | |
Next | |
ElseIf oList( intCount )( 0 ) = strFormName Then | |
' it´s the forms own properties | |
For intSub = 1 To UBound( oList( intCount ) ) | |
oElement = Split( oList( intCount )( intSub ), "=" ) | |
If IsArray( oElement ) Then | |
If UBound( oElement ) = 1 Then | |
Call Me.SetProperty( oElement( 0 ), objForm.URLDecode( oElement( 1 ) ) ) | |
End If | |
End If | |
Next | |
End If | |
End If | |
Next | |
Set oList = Nothing | |
If IsPostBack Then | |
' update the correct values submitted by the users | |
For Each sElement in objQueue | |
If objForm.Form.Exists( sElement ) Then | |
objQueue.Item( sElement ).Value = objForm.Form.GetValue( sElement ) | |
End If | |
Next | |
' check for triggered events | |
If objForm.Form.Item( "_EVENTTARGET" ) <> "" Then | |
For Each sElement in objQueue | |
If sElement = objForm.Form.Item( "_EVENTTARGET" ) Then | |
Call objQueue.Item( sElement ).EventHandler( objForm.Form.Item( "_EVENTTARGET" ), objForm.Form.Item( "_EVENTARGS" ) ) | |
Exit For | |
End If | |
Next | |
End If | |
' call the event handler | |
If boolEvtFileUpload Then | |
on error resume next | |
Call evtFileUpload( objForm.Files ) | |
on error goto 0 | |
ElseIf strSavePath <> "undefined" Then | |
If objForm.Files.Count > 1 Then | |
For intCount = 0 To objForm.Files.Count - 1 | |
Call objForm.Files.Item( intCount ).Save( strSavePath ) | |
Next | |
ElseIf objForm.Files.Count = 1 Then | |
Call objForm.Files.Item( 0 ).Save( strSavePath ) | |
End If | |
End If | |
End If | |
' call the event handler | |
If boolEvtLoad Then | |
on error resume next | |
Call evtLoad | |
on error goto 0 | |
End If | |
End Sub | |
' prints the <form> element and the main javascript behaviors | |
Public Sub RenderBegin | |
Dim strHTML | |
If boolHashPassword Then | |
strHTML = strHTML & vbCRLF & _ | |
"<script language=""javascript"" src=""" & strJSMD5Path & """></script>" & vbCRLF | |
End If | |
strHTML = strHTML & vbCRLF & _ | |
"<script language=""javascript""><" & "!--" & vbCRLF & _ | |
"var __IsPosting = false; // flag to avoid double-posting commands" & vbCRLF & _ | |
"var __arrValidators = new Array(); " & vbCRLF & _ | |
"function _doSubmit() { " & vbCRLF & _ | |
" if ( __IsPosting ) { return false } " & vbCRLF & _ | |
" __IsPosting = true; " & vbCRLF & _ | |
" var boolReturn = true; " & vbCRLF & _ | |
" if ( __arrValidators.length > 0 ) { " & vbCRLF & _ | |
" for ( var i = 0; i < __arrValidators.length; i++ ) { " & vbCRLF & _ | |
" boolReturn = boolReturn && eval( __arrValidators[ i ] ); " & vbCRLF & _ | |
" } " & vbCRLF & _ | |
" }" & vbCRLF & _ | |
" if ( boolReturn ) { " & vbCRLF & _ | |
" _hashPassword(); " & vbCRLF & _ | |
" %formname.submit(); " & vbCRLF & _ | |
" } else { " & vbCRLF & _ | |
" __IsPosting = false;" & vbCRLF & _ | |
" } " & vbCRLF & _ | |
" return false; " & vbCRLF & _ | |
"} " & vbCRLF | |
If boolHashPassword Then | |
strHTML = strHTML & vbCRLF & _ | |
"function _hashPassword() { " & vbCRLF & _ | |
" if ( ! MD5 ) { " & vbCRLF & _ | |
" return;" & vbCRLF & _ | |
" } " & vbCRLF & _ | |
" var strUsername = ''; " & vbCRLF & _ | |
" if ( %formname.username ) { " & vbCRLF & _ | |
" strUsername = %formname.username.value + ':'; " & vbCRLF & _ | |
" } " & vbCRLF & _ | |
" for( var i = 0; i < %formname.elements.length; i++ ) { " & vbCRLF & _ | |
" if ( %formname.elements[ i ].type == 'password' ) { " & vbCRLF & _ | |
" strHash = MD5( strUsername + MD5( %formname.elements[ i ].value ) + ':' + %formname._CHALLENGE.value ); " & vbCRLF & _ | |
" %formname.elements[ i ].value = strHash; " & vbCRLF & _ | |
" } " & vbCRLF & _ | |
" } " & vbCRLF & _ | |
"} " & vbCRLF | |
Else | |
strHTML = strHTML & vbCRLF & _ | |
"function _hashPassword() {}" & vbCRLF | |
End If | |
strHTML = strHTML & vbCRLF & _ | |
"function _doPostBack( element, args ) { " & vbCRLF & _ | |
" %formname._EVENTTARGET.value = element; " & vbCRLF & _ | |
" %formname._EVENTARGS.value = args; " & vbCRLF & _ | |
" _doSubmit(); " & vbCRLF & _ | |
"} " & vbCRLF & _ | |
"//--" & "></script>" & vbCRLF & _ | |
"<form id=""%formname"" name=""%formname"" method=""POST"" action=""%url"" %encode onsubmit=""return _doSubmit()"">" & vbCRLF & _ | |
"<input type=""hidden"" id=""_VIEWSTATE"" name=""_VIEWSTATE"" value=""%viewstate"">" & vbCRLF & _ | |
"<input type=""hidden"" id=""_EVENTTARGET"" name=""_EVENTTARGET"">" & vbCRLF & _ | |
"<input type=""hidden"" id=""_EVENTARGS"" name=""_EVENTARGS"">" & vbCRLF & _ | |
"<input type=""hidden"" id=""_CHALLENGE"" name=""_CHALLENGE"" value=""%challenge"">" & vbCRLF | |
' add upload capability | |
If boolEncode Then | |
strHTML = Replace( strHTML, "%encode", "ENCTYPE=""multipart/form-data""" ) | |
Else | |
strHTML = Replace( strHTML, "%encode", "" ) | |
End If | |
Randomize | |
strHTML = Replace( strHTML, "%challenge", Round( Rnd * 30000 ) + 1 ) | |
strHTML = Replace( strHTML, "%formname", strFormName, 1, -1 ) | |
strHTML = Replace( strHTML, "%url", Request.ServerVariables( "PATH_INFO" ) ) | |
strHTML = Replace( strHTML, "%viewstate", Serialize() ) | |
Response.Write strHTML | |
End Sub | |
' print the end of the <form> element | |
Public Sub RenderEnd | |
Response.Write vbCRLF & "</form>" & vbCRLF | |
' call the event handler | |
If boolEvtTerminate Then | |
on error resume next | |
Call evtTerminate | |
on error goto 0 | |
End If | |
End Sub | |
End Class | |
' | |
' Encapsulates a Button object | |
' | |
Class Button | |
Private objParent | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private boolVisible | |
Private boolSerialize | |
Private evtClick | |
Private boolEvtClick | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
boolVisible = True | |
boolSerialize = True | |
boolEvtClick = False | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "click" Then | |
If boolEvtClick Then | |
Call evtClick( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnClick( ByRef subRef ) : Set evtClick = subRef : boolEvtClick = True : End Property | |
' type of this object | |
Public Property Get IsType : IsType = "button" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the current value of the object | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value( str ) : strValue = str : End Property | |
' the required name of the object | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML, strComplement | |
If boolEvtClick Then | |
strComplement = "onclick=""_doPostBack( '%name', 'click' )"" " | |
End If | |
strHTML = "<input type=""button"" id=""%name"" name=""%name""%style%class value=""%value"" %complement/>" | |
strHTML = Replace( strHTML, "%complement", strComplement ) | |
strHTML = Replace( strHTML, "%value", Replace( strValue, """", "\""", 1, -1 ) ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """" ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """" ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates a Label object | |
' | |
Class Label | |
Private objParent | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private boolVisible | |
Private boolSerialize | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
boolVisible = True | |
boolSerialize = True | |
End Sub | |
' dummy event handler | |
Public Sub EventHandler( sender, arguments ) : End Sub | |
' type of this object | |
Public Property Get IsType : IsType = "label" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' get/set required name for this element | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name ( str ) : strName = str : End Property | |
' get/set the value | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value ( str ) : strValue = str : End Property | |
' get/set the style | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style ( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' serializes | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' called by the parent Page class and must be able to set | |
' all of it´s own properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
End Select | |
End Sub | |
' renders the HTML control in the page | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML | |
strHTML = "<span id=""%name""%style%class>%value</span>" | |
strHTML = Replace( strHTML, "%value", strValue ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """" ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """" ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates a TextBox object | |
' | |
Class TextBox | |
Private objParent | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private intMaxLength | |
Private intRows | |
Private intCols | |
Private boolVisible | |
Private boolSerialize | |
Private boolPassword | |
Private evtChange | |
Private boolEvtChange | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
intMaxLength = 0 | |
intRows = 1 | |
intCols = 15 | |
boolVisible = True | |
boolSerialize = True | |
boolPassword = False | |
boolEvtChange = False | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "change" Then | |
If boolEvtChange Then | |
Call evtChange( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnChange( ByRef subRef ) : Set evtChange = subRef : boolEvtChange = True : End Property | |
' type of this object | |
Public Property Get IsType : IsType = "textbox" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' get/set required name for this element | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name ( str ) : strName = str : End Property | |
' get/set the value | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value ( str ) : strValue = str : End Property | |
' get/set the style | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style ( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set the field max char length | |
Public Property Get MaxLength : MaxLength = intMaxLength : End Property | |
Public Property Let MaxLength ( intTmp ) | |
If IsNumeric( intTmp ) Then | |
on error resume next | |
intMaxLength = CInt( intTmp ) | |
If Err.number <> 0 Then | |
intMaxLength = 0 | |
End If | |
on error goto 0 | |
End If | |
End Property | |
' get/set the number of rows | |
Public Property Get Rows : Rows = intRows : End Property | |
Public Property Let Rows ( intCount ) | |
If IsNumeric( intCount ) Then | |
on error resume next | |
intRows = CInt( intCount ) | |
If Err.number <> 0 Then | |
intRows = 1 | |
End If | |
on error goto 0 | |
End If | |
End Property | |
' get/set the number of columns | |
Public Property Get Columns : Columns = intCols : End Property | |
Public Property Let Columns ( intCount ) | |
If IsNumeric( intCount ) Then | |
on error resume next | |
intCols = CInt( intCount ) | |
If Err.number <> 0 Then | |
intCols = 15 | |
End If | |
on error goto 0 | |
End If | |
End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' get/set if it´s a password input box | |
Public Property Get IsPassword : IsPassword = boolPassword : End Property | |
Public Property Let IsPassword( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolPassword = True | |
Else | |
boolPassword = False | |
End If | |
End Property | |
' serializes | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "maxlength", intMaxLength ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "rows", intRows ) & _ | |
Parent.ChildSerializeNode( "cols", intCols ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' called by the parent Page class and must be able to set | |
' all of it´s own properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "maxlength" | |
MaxLength = strArg | |
Case "style" | |
Style = strArg | |
Case "visible" | |
Visible = strArg | |
Case "rows" | |
Rows = strArg | |
Case "cols" | |
Columns = strArg | |
End Select | |
End Sub | |
' renders the HTML control in the page | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
' password fields can´t be text based | |
If IsPassword Then | |
intRows = 1 | |
End If | |
Dim strHTML, sComplement | |
If intRows = "1" Then | |
strHTML = "<input type=""%type"" id=""%name"" name=""%name"" size=""%cols"" value=""%value""%style%class%complement />" | |
Else | |
strHTML = "<textarea id=""%name"" name=""%name"" rows=""%rows"" cols=""%cols""%style%class%complement>%value</textarea>" | |
End If | |
sComplement = "" | |
If boolEvtChange Then | |
sComplement = " onchange=""_doPostBack( '%name', 'change' )"" " | |
End If | |
If intMaxLength > 0 Then | |
sComplement = " maxlength=""" & intMaxLength & """ " & sComplement | |
End If | |
strHTML = Replace( strHTML, "%complement", sComplement ) | |
strHTML = Replace( strHTML, "%rows", intRows ) | |
strHTML = Replace( strHTML, "%cols", intCols ) | |
If Not IsPassword Then | |
strHTML = Replace( strHTML, "%value", Replace( strValue, """", "\""", 1, -1 ) ) | |
strHTML = Replace( strHTML, "%type", "text" ) | |
Else | |
strHTML = Replace( strHTML, "%value", "" ) | |
strHTML = Replace( strHTML, "%type", "password" ) | |
End If | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """ " ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """ " ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates the functionallity of a drop down list | |
' | |
Class DropDownList | |
Private objParent | |
Private objList | |
Private arrSelected | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private intRows | |
Private boolMultiple | |
Private boolVisible | |
Private boolSerialize | |
Private constElementDivider | |
Private constTokenDivider | |
Private evtChange | |
Private boolEvtChange | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
intRows = 1 | |
boolMultiple = False | |
boolVisible = True | |
boolSerialize = True | |
constElementDivider = "#@#" | |
constTokenDivider = "@#@" | |
boolEvtChange = False | |
Set objList = Server.CreateObject( "Scripting.Dictionary" ) | |
objList.RemoveAll | |
End Sub | |
Private Sub Class_Terminate | |
Set objList = Nothing | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "change" Then | |
If boolEvtChange Then | |
Call evtChange( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnChange( ByRef subRef ) : Set evtChange = subRef : boolEvtChange = True : End Property | |
' type of this object | |
Public Property Get IsType : IsType = "dropdown" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the required name of the object | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set the Items (Dictionary) object | |
' any Dictionary can be connected here, but if there´s no dictionary the | |
' object will categorically fail without warning | |
Public Property Get Items : Set Items = objList : End Property | |
Public Property Let Items ( ByRef obj ) : Set objList = obj : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' get/set multiple select | |
Public Property Get AllowMultiple : AllowMultiple = boolMultiple : End Property | |
Public Property Let AllowMultiple( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolMultiple = True | |
Else | |
boolMultiple = False | |
End If | |
End Property | |
' the current selected indexes | |
Public Property Get Value | |
If IsArray( arrSelected ) Then | |
Value = arrSelected | |
End If | |
End Property | |
Public Property Let Value( str ) | |
str = Replace( str, ", ", ",", 1, -1 ) | |
If InStr( str, "," ) Then | |
arrSelected = Split( str, "," ) | |
Else | |
arrSelected = Array( str ) | |
End If | |
Dim intCount | |
on error resume next | |
For intCount = 0 To UBound( arrSelected ) | |
arrSelected( intCount ) = CInt( arrSelected( intCount ) ) | |
Next | |
on error goto 0 | |
End Property | |
' retrieves a value for it´s Index | |
Public Function GetValue( index ) | |
If IsNumeric( index ) and index < objList.Count Then | |
Dim arrTmp | |
arrTmp = objList.Items | |
GetValue = arrTmp( index ) | |
Else | |
If objList.Exists( index ) Then | |
GetValue = objList( index ) | |
End If | |
End If | |
End Function | |
' retrieves a key for it´s index | |
Public Function GetKey( index ) | |
If IsNumeric( index ) and index < objList.Count Then | |
Dim arrTmp | |
arrTmp = objList.Keys | |
GetKey = arrTmp( index ) | |
End If | |
End Function | |
' total number of returned selected elements | |
Public Property Get SelectedCount | |
SelectedCount = 0 | |
If IsArray( arrSelected ) Then | |
SelectedCount = CInt( UBound( arrSelected ) ) + 1 | |
End If | |
End Property | |
' total number of elements | |
Public Property Get Count : Count = objList.Count : End Property | |
' get/set number of rows | |
Public Property Get Rows : Rows = intRows : End Property | |
Public Property Let Rows( intNumber ) | |
If IsNumeric( intNumber ) Then | |
on error resume next | |
intNumber = CInt( intNumber ) | |
If Err.number <> 0 or intNumber < 1 Then | |
intNumber = 1 | |
End If | |
on error goto 0 | |
intRows = intNumber | |
End If | |
End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) & _ | |
Parent.ChildSerializeNode( "multiple", boolMultiple ) & _ | |
Parent.ChildSerializeNode( "rows", intRows ) | |
' serialize the list values | |
Dim strKey, strList | |
For Each strKey in objList | |
strList = strList & strKey & constTokenDivider & objList( strKey ) & constElementDivider | |
Next | |
If strList <> "" Then | |
strList = Left( strList, Len( strList ) - Len( constElementDivider ) ) | |
strXML = strXML & Parent.ChildSerializeNode( "list", strList ) | |
End If | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
Case "multiple" | |
AllowMultiple = strArg | |
Case "rows" | |
Rows = strArg | |
Case "list" | |
' deserialize list | |
Dim arrList, intCount, arrElement | |
arrList = Split( strArg, constElementDivider ) | |
objList.RemoveAll | |
For intCount = 0 To UBound( arrList ) | |
arrElement = Split( arrList( intCount ), constTokenDivider ) | |
If IsArray( arrElement ) Then | |
If UBound( arrElement ) = 1 Then | |
objList.Add arrElement( 0 ), arrElement( 1 ) | |
End If | |
End If | |
Next | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML, strComplement | |
If intRows > 1 Then | |
strComplement = " size=""" & intRows & """ " | |
End If | |
If boolEvtChange Then | |
strComplement = strComplement & " onchange=""_doPostBack( '%name', 'change' )"" " | |
End If | |
If boolMultiple Then | |
strComplement = strComplement & " multiple=""multiple"" " | |
End If | |
strHTML = "<select id=""%name"" name=""%name""%style%class %complement>" & vbCRLF | |
strHTML = Replace( strHTML, "%complement", strComplement ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """" ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """" ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
' print the items | |
Dim strSelected, intTmp, intCount | |
intCount = 0 | |
If objList.Count > 0 Then | |
For Each strKey in objList | |
strSelected = "" | |
If IsArray( arrSelected ) Then | |
For Each intTmp in arrSelected | |
If intTmp = intCount Then | |
strSelected = " selected=""selected""" | |
Exit For | |
End If | |
Next | |
End If | |
strHTML = strHTML & "<option value=""" & intCount & """" & strSelected & ">" & strKey & "</option>" & vbCRLF | |
intCount = intCount + 1 | |
Next | |
End If | |
strHTML = strHTML & "</select>" & vbCRLF | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates the functionallity of a group set of radio or check boxes | |
' | |
Class List | |
Private objParent | |
Private objList | |
Private arrSelected | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private boolVertical | |
Private boolMultiple | |
Private boolVisible | |
Private boolSerialize | |
Private constElementDivider | |
Private constTokenDivider | |
Private evtChange | |
Private boolEvtChange | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
boolMultiple = False | |
boolVertical = True | |
boolVisible = True | |
boolSerialize = True | |
constElementDivider = "#@#" | |
constTokenDivider = "@#@" | |
boolEvtChange = False | |
Set objList = Server.CreateObject( "Scripting.Dictionary" ) | |
objList.RemoveAll | |
End Sub | |
Private Sub Class_Terminate | |
Set objList = Nothing | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "change" Then | |
If boolEvtChange Then | |
Call evtChange( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnChange( ByRef subRef ) : Set evtChange = subRef : boolEvtChange = True : End Property | |
' type of this object | |
Public Property Get IsType | |
If boolMultiple Then | |
IsType = "checklist" | |
Else | |
IsType = "radiolist" | |
End If | |
End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the required name of the object | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set the Items (Dictionary) object | |
' any Dictionary can be connected here, but if there´s no dictionary the | |
' object will categorically fail without warning | |
Public Property Get Items : Set Items = objList : End Property | |
Public Property Let Items ( ByRef obj ) : Set objList = obj : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' get/set multiple select | |
Public Property Get AllowMultiple : AllowMultiple = boolMultiple : End Property | |
Public Property Let AllowMultiple( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolMultiple = True | |
Else | |
boolMultiple = False | |
End If | |
End Property | |
' get/set direction of the rendering | |
Public Property Get Vertical : Vertical = boolVertical : End Property | |
Public Property Let Vertical( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVertical = True | |
Else | |
boolVertical = False | |
End If | |
End Property | |
' the current selected values | |
Public Property Get Value | |
If IsArray( arrSelected ) Then | |
Value = arrSelected | |
End If | |
End Property | |
Public Property Let Value( str ) | |
str = Replace( str, ", ", ",", 1, -1 ) | |
If InStr( str, "," ) Then | |
arrSelected = Split( str, "," ) | |
Else | |
arrSelected = Array( str ) | |
End If | |
Dim intCount | |
on error resume next | |
For intCount = 0 To UBound( arrSelected ) | |
arrSelected( intCount ) = CInt( arrSelected( intCount ) ) | |
Next | |
on error goto 0 | |
End Property | |
' retrieves a value for it´s Index | |
Public Function GetValue( index ) | |
If IsNumeric( index ) and index < objList.Count Then | |
Dim arrTmp | |
arrTmp = objList.Items | |
GetValue = arrTmp( index ) | |
Else | |
If objList.Exists( index ) Then | |
GetValue = objList( index ) | |
End If | |
End If | |
End Function | |
' retrieves a key for it´s index | |
Public Function GetKey( index ) | |
If IsNumeric( index ) and index < objList.Count Then | |
Dim arrTmp | |
arrTmp = objList.Keys | |
GetKey = arrTmp( index ) | |
End If | |
End Function | |
' total number of returned selected elements | |
Public Property Get SelectedCount | |
SelectedCount = 0 | |
If IsArray( arrSelected ) Then | |
SelectedCount = CInt( UBound( arrSelected ) ) + 1 | |
End If | |
End Property | |
' total number of elements | |
Public Property Get Count : Count = objList.Count : End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) & _ | |
Parent.ChildSerializeNode( "multiple", boolMultiple ) & _ | |
Parent.ChildSerializeNode( "vertical", boolVertical ) | |
' serialize the list values | |
Dim strKey, strList | |
For Each strKey in objList | |
strList = strList & strKey & constTokenDivider & objList( strKey ) & constElementDivider | |
Next | |
If strList <> "" Then | |
strList = Left( strList, Len( strList ) - Len( constElementDivider ) ) | |
strXML = strXML & Parent.ChildSerializeNode( "list", strList ) | |
End If | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
Case "multiple" | |
AllowMultiple = strArg | |
Case "vertical" | |
Vertical = strArg | |
Case "list" | |
' deserialize list | |
Dim arrList, intCount, arrElement | |
arrList = Split( strArg, constElementDivider ) | |
objList.RemoveAll | |
For intCount = 0 To UBound( arrList ) | |
arrElement = Split( arrList( intCount ), constTokenDivider ) | |
If IsArray( arrElement ) Then | |
If UBound( arrElement ) = 1 Then | |
objList.Add arrElement( 0 ), arrElement( 1 ) | |
End If | |
End If | |
Next | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML, strElement, strComplement | |
If boolEvtChange Then | |
strComplement = strComplement & " onchange=""_doPostBack( '%name', 'change' )"" " | |
End If | |
strElement = "<input type=""%type"" id=""%name"" name=""%name"" value=""%value"" %style%class%complement%selected/> %key" | |
strElement = Replace( strElement, "%complement", strComplement ) | |
strElement = Replace( strElement, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strElement = Replace( strElement, "%style", " style=""" & strStyle & """" ) | |
Else | |
strElement = Replace( strElement, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strElement = Replace( strElement, "%class", " class=""" & strClass & """" ) | |
Else | |
strElement = Replace( strElement, "%class", "" ) | |
End If | |
If boolMultiple Then | |
strElement = Replace( strElement, "%type", "checkbox" ) | |
Else | |
strElement = Replace( strElement, "%type", "radio" ) | |
End If | |
If boolVertical Then | |
strElement = strElement & "<br />" | |
Else | |
strElement = strElement & " " | |
End If | |
strElement = strElement & vbCRLF | |
' print the items | |
Dim strSelected, intTmp, intCount | |
intCount = 0 | |
If objList.Count > 0 Then | |
For Each strKey in objList | |
strSelected = "" | |
If IsArray( arrSelected ) Then | |
For Each intTmp in arrSelected | |
If intCount = intTmp Then | |
strSelected = " checked=""checked""" | |
Exit For | |
End If | |
Next | |
End If | |
strTmp = Replace( strElement, "%value", intCount ) | |
strTmp = Replace( strTmp, "%key", strKey ) | |
strTmp = Replace( strTmp, "%selected", strSelected ) | |
strHTML = strHTML & strTmp | |
intCount = intCount + 1 | |
Next | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates a Button object | |
' | |
Class FileUpload | |
Private objParent | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private intSize | |
Private intMaxLength | |
Private boolVisible | |
Private boolSerialize | |
Private evtChange | |
Private boolEvtChange | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
intSize = 0 | |
intMaxLength = 0 | |
boolVisible = True | |
boolSerialize = True | |
boolEvtChange = False | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "change" Then | |
If boolEvtChange Then | |
Call evtChange( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnChange( ByRef subRef ) : Set evtChange = subRef : boolEvtChange = True : End Property | |
' type of this object | |
Public Property Get IsType : IsType = "fileupload" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the current value of the object | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value( str ) : strValue = str : End Property | |
' the required name of the object | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set the char size | |
Public Property Get Size : Size = intSize : End Property | |
Public Property Let Size ( intTmp ) | |
If IsNumeric( intTmp ) Then | |
on error resume next | |
intSize = CInt( intTmp ) | |
If Err.number <> 0 Then | |
intSize = 0 | |
End If | |
on error goto 0 | |
End If | |
End Property | |
' get/set the field max char length | |
Public Property Get MaxLength : MaxLength = intMaxLength : End Property | |
Public Property Let MaxLength ( intTmp ) | |
If IsNumeric( intTmp ) Then | |
on error resume next | |
intMaxLength = CInt( intTmp ) | |
If Err.number <> 0 Then | |
intMaxLength = 0 | |
End If | |
on error goto 0 | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "size", intSize ) & _ | |
Parent.ChildSerializeNode( "maxlength", intMaxLength ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "size" | |
Size = strArg | |
Case "maxlength" | |
MaxLength = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
' only allow uploads if the form allows it too | |
If Not objParent.AllowUpload Then | |
Exit Sub | |
End If | |
Dim strHTML, strComplement | |
If boolEvtChange Then | |
strComplement = "onchange=""_doPostBack( '%name', 'change' )"" " | |
End If | |
If intMaxLength > 0 Then | |
strComplement = "maxlength=""" & intMaxLength & """ " & sComplement | |
End If | |
If intSize > 0 Then | |
strComplement = "size=""" & intSize & """ " & sComplement | |
End If | |
strHTML = "<input type=""file"" id=""%name"" name=""%name""%style%class value=""%value"" %complement/>" | |
strHTML = Replace( strHTML, "%complement", strComplement ) | |
strHTML = Replace( strHTML, "%value", Replace( strValue, """", "\""", 1, -1 ) ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """" ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """" ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates an Image object | |
' | |
Class Image | |
Private objParent | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private strToopTip | |
Private boolVisible | |
Private boolSerialize | |
Private evtClick | |
Private boolEvtClick | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
strToolTip = "" | |
boolVisible = True | |
boolSerialize = True | |
boolEvtClick = False | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "click" Then | |
If boolEvtClick Then | |
Call evtClick( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnClick( ByRef subRef ) : Set evtClick = subRef : boolEvtClick = True : End Property | |
' type of this object | |
Public Property Get IsType : IsType = "image" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the current value of the object | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value( str ) : strValue = str : End Property | |
' tool tip | |
Public Property Get ToolTip : ToolTip = strToolTip : End Property | |
Public Property Let ToolTip( str ) : strToolTip = str : End Property | |
' wraps the "Value" as a "Path" | |
Public Property Get Path : Path = strValue : End Property | |
Public Property Let Path( str ) : strValue = str : End Property | |
' the required name of the object | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "tip", strToolTip ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "tip" | |
ToolTip = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML, strComplement | |
If boolEvtClick Then | |
strComplement = "onclick=""_doPostBack( '%name', 'click' )"" " | |
else | |
strComplement = "onclick=""return false;"" " | |
End If | |
If strToolTip <> "" Then | |
strComplement = "alt=""" & strToolTip & """ " & strComplement | |
End If | |
strHTML = "<input type=""image"" id=""%name"" name=""%name""%style%class src=""%value"" %complement/>" | |
strHTML = Replace( strHTML, "%complement", strComplement ) | |
strHTML = Replace( strHTML, "%value", Replace( strValue, """", "\""", 1, -1 ) ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """" ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """" ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates a Hidden data-only object | |
' | |
Class Hidden | |
Private objParent | |
Private strName | |
Private strValue | |
Private boolVisible | |
Private boolSerialize | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
boolVisible = True | |
boolSerialize = True | |
End Sub | |
' dummy handler | |
Public Sub EventHandler( sender, arguments ) : End Sub | |
' type of this object | |
Public Property Get IsType : IsType = "hidden" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the current value of the object | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value( str ) : strValue = str : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "visible" | |
Visible = strArg | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML | |
strHTML = "<input type=""hidden"" id=""%name"" name=""%name"" value=""%value"" />" | |
strHTML = Replace( strHTML, "%value", Replace( strValue, """", "\""", 1, -1 ) ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates an HTML link | |
' | |
Class Anchor | |
Private objParent | |
Private strName | |
Private strValue | |
Private strStyle | |
Private strClass | |
Private boolVisible | |
Private boolSerialize | |
Private evtClick | |
Private boolEvtClick | |
' constructor | |
Private Sub Class_Initialize | |
strName = "" | |
strValue = "" | |
strStyle = "" | |
boolVisible = True | |
boolSerialize = True | |
boolEvtClick = False | |
End Sub | |
' global event handler for this element | |
Public Sub EventHandler( sender, arguments ) | |
If arguments = "click" Then | |
If boolEvtClick Then | |
Call evtClick( sender, arguments ) | |
End If | |
End If | |
End Sub | |
' set the click event handler for this object | |
Public Property Let OnClick( ByRef subRef ) : Set evtClick = subRef : boolEvtClick = True : End Property | |
' type of this object | |
Public Property Get IsType : IsType = "anchor" : End Property | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' the required name of the object | |
Public Property Get Name : Name = strName : End Property | |
Public Property Let Name( str ) : strName = str : End Property | |
' the current value of the object | |
Public Property Get Value : Value = strValue : End Property | |
Public Property Let Value( str ) : strValue = str : End Property | |
' the required name of the object | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
' get/set the CSS class name | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName ( str ) : strClass = str : End Property | |
' get/set visibility | |
Public Property Get Visible : Visible = boolVisible : End Property | |
Public Property Let Visible( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolVisible = True | |
Else | |
boolVisible = False | |
End If | |
End Property | |
' get/set serialization behavior | |
Public Property Get CanSerialize : CanSerialize = boolSerialize : End Property | |
Public Property Let CanSerialize( bool ) | |
If bool and LCase( bool ) <> "false" Then | |
boolSerialize = True | |
Else | |
boolSerialize = False | |
End If | |
End Property | |
' persists it´s current state in a XML stream | |
Public Function Serialize | |
Dim strXML | |
strXML = strName | |
If Not boolSerialize Then | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "serialize", "false" ) | |
Else | |
strXML = strXML & _ | |
Parent.ChildSerializeNode( "name", strName ) & _ | |
Parent.ChildSerializeNode( "value", strValue ) & _ | |
Parent.ChildSerializeNode( "style", strStyle ) & _ | |
Parent.ChildSerializeNode( "class", strClass ) & _ | |
Parent.ChildSerializeNode( "visible", boolVisible ) | |
End If | |
Serialize = strXML | |
End Function | |
' wraps the object´s properties | |
Public Sub SetProperty( strKey, strArg ) | |
Select Case strKey | |
Case "name" | |
Name = strArg | |
Case "value" | |
Value = strArg | |
Case "style" | |
Style = strArg | |
Case "class" | |
ClassName = strArg | |
Case "visible" | |
Visible = strArg | |
End Select | |
End Sub | |
' prints it´s current HTML element | |
Public Sub Render | |
If Not Visible Then | |
Exit Sub | |
End If | |
Dim strHTML, strComplement | |
If boolEvtClick Then | |
strComplement = "href=""javascript:_doPostBack( '%name', 'click' )"" " | |
Else | |
strComplement = "href=""#"" " | |
End If | |
strHTML = "<a id=""%name"" name=""%name""%style%class %complement>%value</a>" | |
strHTML = Replace( strHTML, "%complement", strComplement ) | |
strHTML = Replace( strHTML, "%value", Replace( strValue, """", "\""", 1, -1 ) ) | |
strHTML = Replace( strHTML, "%name", strName, 1, -1 ) | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """" ) | |
Else | |
strHTML = Replace( strHTML, "%style", "" ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """" ) | |
Else | |
strHTML = Replace( strHTML, "%class", "" ) | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
%> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
<% | |
' | |
' Replaces the built-in ASP Session object | |
' Advantages: | |
' - does not consume local resources | |
' - allows true Web Farms because the user doesn´t have to get back to the | |
' same server all the time, which means that it allows for true load balancing | |
' with users accessing different servers but still having a solid session | |
' - expiration customizable in the level of the page | |
' | |
' Requirements | |
' - MD5.asp (Class MD5) | |
' - RDBMS database access and the following table structure | |
' - Base64.asp (Class Base64) | |
' - a Data Adaptor Class (more on this at the end of the SessionPlus implementation) | |
' | |
' create table tbSessionPlus ( | |
' userid varchar2( 40 ) not null, | |
' keyname varchar2( 100 ) not null, | |
' value varchar2( 8000 ) not null, | |
' expiration date not null | |
' ) | |
' | |
Class SessionPlus | |
Private strUserID | |
Private objBase64 | |
Private objItems | |
Private dtExpire | |
Private objDataAdaptor | |
Private boolCommit | |
' get/set an MD5 unique identifier (pseudo-unique but very close to the 128 bit GUID) | |
Property Get UserID : UserID = strUserID : End Property | |
Property Let UserID( str ) : strUserID = str : End Property | |
' get/set expiration date for the current values (must be set before Commit) | |
Property Get Expire : Expire = dtExpire : End Property | |
Property Let Expire( dtTmp ) | |
If IsDate( dtTmp ) Then | |
dtExpire = dtTmp | |
End If | |
End Property | |
' get/set an external data adaptor that exposes a Save method that receives the | |
' current data | |
Property Get DataAdaptor : Set DataAdaptor = objDataAdaptor : End Property | |
Property Let DataAdaptor( ByRef obj ) | |
If IsObject( obj ) Then | |
Set objDataAdaptor = obj | |
End If | |
End Property | |
' total items | |
Property Get Count : Count = objItems.Count : End Property | |
' constructor | |
Private Sub Class_Initialize | |
Dim objMD5, strSeed | |
boolCommit = False | |
dtExpire = DateAdd( "h", 1, Now ) ' expires in an hour | |
Set objDataAdaptor = Nothing | |
Set objMD5 = new MD5 | |
Set objBase64 = new Base64 | |
Set objItems = Server.CreateObject( "Scripting.Dictionary" ) | |
' check if the user already has an ID, otherwise generate a new one based on MD5 | |
strUserID = Trim( Request.Cookies( "SESSIONKEYPLUS" ) ) | |
If strUserID = "" Then | |
Randomize | |
strSeed = Request.ServerVariables( "REMOTE_ADDR" ) & _ | |
Day( Now ) & Month( Now ) & Year( Now ) & Hour( Now ) & Minute( Now ) & Second( Now ) & Hex( Rnd * 30000 ) | |
strUserID = objMD5.MakeDigest( strSeed ) | |
End If | |
Set objMD5 = Nothing | |
' try to write in the cookie header | |
on error resume next | |
Response.Cookies( "SESSIONKEYPLUS" ) = strUserID | |
Response.Cookies( "SESSIONKEYPLUS" ).Path = "/" | |
on error goto 0 | |
End Sub | |
' destructor - clean up | |
Private Sub Class_Terminate | |
Set objBase64 = Nothing | |
Set objItems = Nothing | |
Set objDataAdaptor = Nothing | |
End Sub | |
' get an item | |
Public Function getItem( strKey ) | |
getItem = objBase64.Decode( objItems( strKey ) ) | |
End Function | |
' set/edit a new item | |
Public Sub setItem( strKey, strValue ) | |
If Not objItems.Exists( strKey ) Then | |
objItems.Add strKey, objBase64.Encode( strValue ) | |
Else | |
objItems( strKey ) = objBase64.Encode( strValue ) | |
End If | |
boolCommit = True | |
End Sub | |
' check a key | |
Public Function hasItem( strKey ) | |
hasItem = objItems.Exists( strKey ) | |
End Function | |
' expires all items | |
Public Sub ExpireAll | |
objItems.RemoveAll | |
End Sub | |
' get the item in the given index | |
Public Function getItemIndex( intIndex ) | |
If intIndex >= objItems.Count Then | |
Exit Function | |
End If | |
Dim arrTokens | |
arrTokens = objItems.Items | |
getItemIndex = arrTokens( intIndex ) | |
End Function | |
' set the item in the given index | |
Public Sub setItemIndex( intIndex, strValue ) | |
If intIndex >= objItems.Count Then | |
Exit Sub | |
End If | |
Dim arrkeys | |
arrkeys = objItems.Keys | |
objItems( arrKeys( intIndex ) ) = strValue | |
boolCommit = True | |
End Sub | |
' get the key in the given index position | |
Public Function getKey( intIndex ) | |
If intIndex >= objItems.Count Then | |
Exit Function | |
End If | |
Dim arrkeys | |
arrkeys = objItems.Keys | |
getKey = arrKeys( intIndex ) | |
End Function | |
' load previously saved user data | |
Public Function Load | |
Load = False | |
If Not IsObject( objDataAdaptor ) or objDataAdaptor Is Nothing Then | |
Exit Function | |
End If | |
With objDataAdaptor | |
.UserID = strUserID | |
.Items = objItems | |
Load = .Retrieve() | |
End With | |
End Function | |
' saves the current user data | |
Public Function Commit | |
' only run a commit transaction if some data were modified, otherwise do nothing | |
If Not boolCommit Then | |
Commit = True | |
Exit Function | |
End If | |
Commit = False | |
If Not IsObject( objDataAdaptor ) or objDataAdaptor Is Nothing Then | |
Exit Function | |
End If | |
With objDataAdaptor | |
.UserID = strUserID | |
.Expire = dtExpire | |
.Items = objItems | |
Commit = .Fetch() | |
End With | |
End Function | |
End Class | |
' | |
' Implements a default Data Adaptor for SQL | |
' Any Class can be an adaptor as far as it implements the following interface: | |
' | |
' Interface IDataAdaptor | |
' Property String UserID (get/set) | |
' Property Scripting.Dictionary Items (get/set) | |
' Property Date Expire (get/set) | |
' | |
' Public Bool Retrieve | |
' Public Bool Fetch | |
' End Interface | |
' | |
Class SQLDataAdaptor | |
Private strUserID | |
Private dtExpire | |
Private objItems | |
Private strTableName | |
Private strConnection | |
Private objConnection | |
Private boolOracle | |
' get/set an MD5 unique identifier (pseudo-unique but very close to the 128 bit GUID) | |
Property Get UserID : UserID = strUserID : End Property | |
Property Let UserID( str ) : strUserID = str : End Property | |
' get/set a Dictionary object from the caller object | |
Property Get Items : Set Items = objItems : End Property | |
Property Let Items( ByRef obj ) | |
If IsObject( obj ) Then | |
Set objItems = obj | |
End If | |
End Property | |
' get/set expiration date for the current values (must be set before Commit) | |
Property Get Expire : Expire = dtExpire : End Property | |
Property Let Expire( dtTmp ) | |
If IsDate( dtTmp ) Then | |
dtExpire = dtTmp | |
End If | |
End Property | |
' get/set the table name | |
Property Get TableName : TableName = strTableName : End Property | |
Property Let TableName( str ) : strTableName = str : End Property | |
' get/set the connection string | |
Property Get ConnectionString : ConnectionString = strConnection : End Property | |
Property Let ConnectionString( str ) : strConnection = str : End Property | |
' get/set a connection object | |
Property Get Connection : Set Connection = objConnection : End Property | |
Property Let Connection( ByRef obj ) : Set objConnection = obj : End Property | |
' get/set whether it´s Oracle or SQL Server | |
Property Get IsOracle : IsOracle = boolOracle : End Property | |
Property Let IsOracle( bool ) | |
If bool Then | |
boolOracle = True | |
Else | |
boolOracle = False | |
End If | |
End Property | |
' constructor | |
Private Sub Class_Initialize | |
boolOracle = True | |
strTableName = "tbSessionPlus" | |
strConnection = "" | |
Set objConnection = Nothing | |
End Sub | |
' go down to the database and query the saved user data | |
Public Function Retrieve | |
Retrieve = False | |
If strConnection = "" and objConnection Is Nothing THen | |
Exit Function | |
End If | |
Dim strSQL, oConn, oRS | |
strSQL = "select userid, keyname, value from " & strTableName & " where expiration >= " | |
If boolOracle Then | |
strSQL = strSQL & "SYSDATE" | |
Else | |
strSQL = strSQL & "GetDate()" | |
End If | |
If objConnection Is Nothing Then | |
Set oConn = Server.CreateObject( "ADODB.Connection" ) | |
on error resume next | |
oConn.Open strConnection | |
If Err.number <> 0 Then | |
Exit Function | |
End If | |
on error goto 0 | |
Else | |
Set oConn = objConnection | |
End If | |
Set oRS = Server.CreateObject( "ADODB.RecordSet" ) | |
oRS.Open strSQL, oConn, 3, 3 | |
' retrieve all values | |
on error resume next | |
Dim strKey, strValue | |
objItems.RemoveAll | |
While Not oRS.EOF | |
strKey = oRS( "keyname" ) | |
strValue = oRS( "value" ) | |
Call objItems.Add( strKey, strValue ) | |
oRS.MoveNext | |
Wend | |
oRS.Close | |
If Err.number = 0 Then | |
Retrieve = True | |
End If | |
on error goto 0 | |
Set oRS = Nothing | |
Set oConn = Nothing | |
End Function | |
' save the users data | |
Public Function Fetch | |
Fetch = False | |
If strConnection = "" and objConnection Is Nothing and objItems.Count > 0 Then | |
Exit Function | |
End If | |
Dim strSQL, strDateFormat, strDate, strTmp, strKey, oConn, strSQLDelete | |
Dim strDay, strMonth, strYear, strHour, strMinute, strSecond, strAMPM, intHour | |
strSQLDelete = "delete from " & strTableName & " where userid = '" & strUserID & "'" | |
strSQL = "insert into " & strTableName & " ( userid, keyname, value, expiration ) values ( '%userid', '%key', '%value', %expiration )" | |
If boolOracle Then | |
strDateFormat = "TO_DATE( ""MM/DD/YYYY HH:MI:SS PM"", ""%date"" )" | |
Else | |
strDateFormat = "'%date'" | |
End If | |
If Not IsDate( dtExpire ) Then | |
dtExpire = Now | |
End If | |
' formats expiration date | |
intHour = Hour( dtExpire ) | |
If intHour > 12 Then | |
intHour = intHour - 12 | |
strAMPM = "PM" | |
ElseIf intHour = 12 Then | |
strAMPM = "PM" | |
Else | |
strAMPM = "AM" | |
End If | |
strDay = FormatInt( Day( dtExpire ), 10 ) | |
strMonth = FormatInt( Month( dtExpire ), 10 ) | |
strYear = FormatInt( Year( dtExpire ), 100 ) | |
strHour = FormatInt( intHour, 10 ) | |
strMinute = FormatInt( Minute( dtExpire ), 10 ) | |
strSecond = FormatInt( Second( dtExpire ), 10 ) | |
strDate = strMonth & "/" & strDay & "/" & strYear & " " & strHour & ":" & strMinute & ":" & strSecond & " " & strAMPM | |
strSQL = Replace( strSQL, "%userid", strUserID ) | |
strSQL = Replace( strSQL, "%expiration", Replace( strDateFormat, "%date", strDate ) ) | |
If objConnection Is Nothing Then | |
Set oConn = Server.CreateObject( "ADODB.Connection" ) | |
on error resume next | |
oConn.Open strConnection | |
If Err.number <> 0 Then | |
Exit Function | |
End If | |
on error goto 0 | |
Else | |
Set oConn = objConnection | |
End If | |
' make all the inserts in a single transaction | |
oConn.BeginTrans | |
on error resume next | |
' delete all data from the database as it will be re-written | |
oConn.Execute strSQLDelete | |
For Each strKey in objItems | |
strTmp = Replace( strSQL, "%key", strKey ) | |
strTmp = Replace( strTmp, "%value", objItems( strKey ) ) | |
oConn.Execute strTmp | |
Next | |
If oConn.Errors.Count > 0 Then | |
oConn.RollBackTrans | |
Else | |
oConn.CommitTrans | |
Fetch = True | |
End If | |
on error goto 0 | |
Set oConn = Nothing | |
End Function | |
' Fetch method helper | |
Private Function FormatInt( strInt, intRange ) | |
If strInt < intRange Then | |
FormatInt = "0" & strInt | |
Else | |
FormatInt = strInt | |
End If | |
End Function | |
End Class | |
%> |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
<% | |
' | |
' Every Validator Class expects the Value property of it´s binded element | |
' and also must implement a IsOk, IsPostBack and ErrorMessage properties that an | |
' external manager as the Form class will access | |
' | |
' | |
' This is a Container for all validators and it can be added | |
' in a Form.ValidatorContainer property | |
' | |
Class ValidatorContainer | |
Private arrControls() | |
Private objParent | |
Private intPointer | |
Private constIncrement | |
Private boolClientSided | |
Private Sub Class_Initialize | |
intPointer = 0 | |
constIncrement = 20 | |
boolClientSided = False | |
ReDim arrControls(50) | |
End Sub | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
' verifies postback from a form | |
Public Property Get IsPostBack | |
IsPostBack = False | |
If Not IsNull( objParent ) Then | |
IsPostBack = objParent.IsPostBack | |
End If | |
End Property | |
' return the form name | |
Public Property Get FormName | |
FormName = False | |
If Not IsNull( objParent ) Then | |
FormName = objParent.FormName | |
End If | |
End Property | |
' dive thru all the validators and join the boolean results | |
Public Property Get IsValid | |
Dim boolOK | |
boolOK = True | |
If intPointer > 0 Then | |
Dim intCount | |
For intCount = 0 To intPointer | |
boolOK = boolOK and arrControls( intPointer ).IsOK | |
Next | |
End If | |
isValid = boolOK | |
End Property | |
' allows the form to be checked prior to a submit | |
Public Property Get IsClientSided | |
IsClientSided = boolClientSided | |
End Property | |
Public Property Let IsClientSided( bool ) | |
If bool and LCase( CStr( bool ) ) <> "false" Then | |
boolClientSided = True | |
Else | |
boolClientSided = False | |
End If | |
End Property | |
' add validators to the container | |
Public Sub Add( ByRef obj ) | |
If intPointer > UBound( arrControls ) Then | |
ReDim Preserve arrControls( intPointer + constIncrement ) | |
End If | |
If Not IsNull( obj ) Then | |
Set arrControls( intPointer ) = obj | |
obj.Parent = Me | |
intPointer = intPointer + 1 | |
End If | |
End Sub | |
' renders the error message if applicable | |
Public Sub ChildRender( boolInvalid, strStyle, strClass, strError ) | |
If Not Me.IsPostBack or boolInvalid Then | |
Exit Sub | |
End If | |
Dim strHTML | |
If strStyle <> "" or strClass <> "" Then | |
strHTML = "<span%style%class>" & strError & "</span>" | |
If strStyle <> "" Then | |
strHTML = Replace( strHTML, "%style", " style=""" & strStyle & """ " ) | |
End If | |
If strClass <> "" Then | |
strHTML = Replace( strHTML, "%class", " class=""" & strClass & """ " ) | |
End If | |
Else | |
strHTML = strError | |
End If | |
Response.Write strHTML | |
End Sub | |
End Class | |
' | |
' Encapsulates a "required field" validation pattern | |
' | |
Class ValidatorRequired | |
Private objParent | |
Private objControl | |
Private boolOK | |
Private strError | |
Private strStyle | |
Private strClass | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
Public Property Let Control( ByRef obj ) : Set objControl = obj : End Property | |
Public Property Get IsOK : IsOK = CheckValue() : End Property | |
Public Property Get ErrorMessage : ErrorMessage = strError : End Property | |
Public Property Let ErrorMessage( str ) : strError = str : End Property | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName( str ) : strClass = str : End Property | |
Private Sub Class_Initialize | |
boolOK = False | |
strError = "" | |
strStyle = "" | |
strClass = "" | |
End Sub | |
' executes the checking | |
Private Function CheckValue | |
CheckValue = False | |
If Not IsNull( objControl ) Then | |
Dim strValue | |
strValue = objControl.Value | |
If Not IsNull( strValue ) and Not IsEmpty( strValue ) and strValue <> "" Then | |
CheckValue = True | |
End If | |
End If | |
End Function | |
' uses the parent render method | |
Public Sub Render | |
If Not IsNull( objParent ) and Not IsNull( objControl ) Then | |
If objParent.IsClientSided Then | |
Dim strHTML, strMessage | |
strMessage = Replace( strError, "'", "\'", 1, -1 ) | |
strMessage = Replace( strMessage, "<br>", "\n", 1, -1 ) | |
strHTML = "<script language=""javascript"">" & vbCRLF & _ | |
"function __ValidatorRequired_" & objControl.Name & "() " & vbCRLF & _ | |
"{ " & vbCRLF & _ | |
" boolResult = ( document." & objParent.FormName & "." & objControl.Name & ".value != '' );" & vbCRLF & _ | |
" if ( ! boolResult ) " & vbCRLF & _ | |
" {" & vbCRLF & _ | |
" alert( '" & strMessage & "' );" & vbCRLF & _ | |
" }" & vbCRLF & _ | |
" return boolResult;" & vbCRLF & _ | |
"} " & vbCRLF & _ | |
"__arrValidators.length ++; " & vbCRLF & _ | |
"__arrValidators[ __arrValidators.length - 1 ] = '__ValidatorRequired_" & objControl.Name & "()';" & vbCRLF & _ | |
"</script>" & vbCRLF | |
Response.Write strHTML | |
End If | |
Call objParent.ChildRender( CheckValue(), strStyle, strClass, strError ) | |
End If | |
End Sub | |
End Class | |
' | |
' Makes a comparison between different objects that implements, at least, | |
' a "Value" property | |
' | |
Class ValidatorCompare | |
Private objParent | |
Private objControl | |
Private objControlValidate | |
Private strValueToCompare | |
Private boolOK | |
Private strOperator | |
Private strError | |
Private strStyle | |
Private strClass | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
Public Property Let Control( ByRef obj ) : Set objControl = obj : End Property | |
Public Property Let ControlToCompare( ByRef obj ) : Set objControlValidate = obj : End Property | |
Public Property Get ValueToCompare : ValueToCompare = strValueToCompare : End Property | |
Public Property Let ValueToCompare( str ) : strValueToCompare = str : End Property | |
Public Property Get IsOK : IsOK = CheckValue() : End Property | |
Public Property Get ErrorMessage : ErrorMessage = strError : End Property | |
Public Property Let ErrorMessage( str ) : strError = str : End Property | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName( str ) : strClass = str : End Property | |
' set which operator to use for comparison | |
Public Property Get Operator : Operator = strOperator : End Property | |
Public Property Let Operator( str ) | |
Dim strAll | |
strAll = "equal | not equal | greater than | less than | greater than equal | less than equal" | |
str = Trim( LCase( str ) ) | |
If InStr( strAll, str ) Then | |
strOperator = str | |
End If | |
End Property | |
Private Sub Class_Initialize | |
boolOK = False | |
strError = "" | |
strOperator = "equal" | |
strValueToCompare = "" | |
End Sub | |
Private Function CheckValue | |
CheckValue = False | |
If Not IsNull( objControl ) and Not IsNull( objControlValidate ) Then | |
on error resume next | |
Dim strValue1, strValue2 | |
strValue1 = Trim( objControl.Value ) | |
If objControlValidate Is Nothing Then | |
strValue2 = Trim( strValueToCompare ) | |
Else | |
strValue2 = Trim( objControlValidate.Value ) | |
End If | |
Select Case strOperator | |
Case "equal" | |
CheckValue = ( strValue1 = strValue2 ) | |
Case "not equal" | |
CheckValue = ( strValue1 <> strValue2 ) | |
Case "greater than" | |
CheckValue = ( strValue1 > strValue2 ) | |
Case "smaller than" | |
CheckValue = ( strValue1 < strValue2 ) | |
Case "greater than equal" | |
CheckValue = ( strValue1 >= strValue2 ) | |
Case "smaller than equal" | |
CheckValue = ( strValue1 <= strValue2 ) | |
End Select | |
If Err.number <> 0 Then | |
CheckValue = False | |
End If | |
on error goto 0 | |
End If | |
End Function | |
' uses the parent render method | |
Public Sub Render | |
If Not IsNull( objParent ) Then | |
If objParent.IsClientSided Then | |
Dim strOperator, strCompare | |
strOperator = "==" | |
Select Case strOperator | |
Case "not equal" | |
strOperator = "!=" | |
Case "greater than" | |
strOperator = ">" | |
Case "smaller than" | |
strOperator = "<" | |
Case "greater than equal" | |
strOperator = ">=" | |
Case "smaller than equal" | |
strOperator = "<=" | |
End Select | |
If objControlValidate Is Nothing Then | |
strCompare = "'" & Replace( Trim( strValueToCompare ), "'", "\'", 1, -1 ) & "'" | |
Else | |
strCompare = "document." & objParent.FormName & "." & objControlValidate.Name & ".value" | |
End If | |
Dim strHTML, strMessage | |
strMessage = Replace( strError, "'", "\'", 1, -1 ) | |
strMessage = Replace( strMessage, "<br>", "\n", 1, -1 ) | |
strHTML = "<script language=""javascript"">" & vbCRLF & _ | |
"function __ValidatorCompare_" & objControl.Name & "() " & vbCRLF & _ | |
"{ " & vbCRLF & _ | |
" boolResult = ( document." & objParent.FormName & "." & objControl.Name & ".value " & strOperator & " " & strCompare & " );" & vbCRLF & _ | |
" if ( ! boolResult ) " & vbCRLF & _ | |
" {" & vbCRLF & _ | |
" alert( '" & strMessage & "' );" & vbCRLF & _ | |
" }" & vbCRLF & _ | |
" return boolResult;" & vbCRLF & _ | |
"} " & vbCRLF & _ | |
"__arrValidators.length ++; " & vbCRLF & _ | |
"__arrValidators[ __arrValidators.length - 1 ] = '__ValidatorCompare_" & objControl.Name & "()';" & vbCRLF & _ | |
"</script>" & vbCRLF | |
Response.Write strHTML | |
End If | |
Call objParent.ChildRender( CheckValue(), strStyle, strClass, strError ) | |
End If | |
End Sub | |
End Class | |
' | |
' Encapsulates a validation of a value agains a regular expression | |
' | |
Class ValidatorRegularExpression | |
Private objParent | |
Private objControl | |
Private boolOK | |
Private strError | |
Private strRegex | |
Private strStyle | |
Private strClass | |
' the required name of the object | |
Public Property Get Parent : Set Parent = objParent : End Property | |
Public Property Let Parent( ByRef refObj ) : Set objParent = refObj : End Property | |
Public Property Let Control( ByRef obj ) : Set objControl = obj : End Property | |
Public Property Get IsOK : IsOK = CheckValue() : End Property | |
Public Property Get ErrorMessage : ErrorMessage = strError : End Property | |
Public Property Let ErrorMessage( str ) : strError = str : End Property | |
Public Property Get Style : Style = strStyle : End Property | |
Public Property Let Style( str ) : strStyle = str : End Property | |
Public Property Get ClassName : ClassName = strClass : End Property | |
Public Property Let ClassName( str ) : strClass = str : End Property | |
Public Property Get RegularExpression : RegularExpression = strRegex : End Property | |
Public Property Let RegularExpression( str ) : strRegex = str : End Property | |
Private Sub Class_Initialize | |
boolOK = False | |
strError = "" | |
strRegex = "" | |
End Sub | |
Private Function CheckValue | |
CheckValue = False | |
If Not IsNull( objControl ) and strRegex <> "" Then | |
' create the regex object (dependes on VBScript 5.1+) | |
Dim objRegex, arrResults | |
Set objRegex = new RegExp | |
objRegex.Pattern = strRegex | |
objRegex.IgnoreCase = True | |
objRegex.Global = True | |
on error resume next | |
Set arrResults = objRegex.Execute( objControl.Value ) | |
If arrResults.Count > 0 Then | |
CheckValue = True | |
End If | |
If Err.number <> 0 Then | |
CheckValue = False | |
End If | |
on error goto 0 | |
Set arrResults = Nothing | |
Set objReges = Nothing | |
End If | |
End Function | |
' uses the parent render method | |
Public Sub Render | |
If Not IsNull( objParent ) Then | |
If objParent.IsClientSided Then | |
Dim strHTML, strMessage | |
strMessage = Replace( strError, "'", "\'", 1, -1 ) | |
strMessage = Replace( strMessage, "<br>", "\n", 1, -1 ) | |
strHTML = "<script language=""JScript"">" & vbCRLF & _ | |
"function __ValidatorRequired_" & objControl.Name & "() " & vbCRLF & _ | |
"{ " & vbCRLF & _ | |
" var __regex = new RegExp( '" & strRegex & "' );" & vbCRLF & _ | |
" var __regexResult = __regex.exec( document." & objParent.FormName & "." & objControl.Name & ".value );" & vbCRLF & _ | |
" boolResult = ( __regexResult != null );" & vbCRLF & _ | |
" if ( ! boolResult ) " & vbCRLF & _ | |
" {" & vbCRLF & _ | |
" alert( '" & strMessage & "' );" & vbCRLF & _ | |
" }" & vbCRLF & _ | |
" return boolResult;" & vbCRLF & _ | |
"} " & vbCRLF & _ | |
"__arrValidators.length ++; " & vbCRLF & _ | |
"__arrValidators[ __arrValidators.length - 1 ] = '__ValidatorRequired_" & objControl.Name & "()';" & vbCRLF & _ | |
"</script>" & vbCRLF | |
Response.Write strHTML | |
End If | |
Call objParent.ChildRender( CheckValue(), strStyle, strClass, strError ) | |
End If | |
End Sub | |
' return default regex | |
Public Function Pattern( strName ) | |
on error resume next | |
strName = LCase( Trim( strName ) ) | |
If Err.number <> 0 Then | |
strName = "" | |
End If | |
on error goto 0 | |
Select Case strName | |
Case "email" | |
Pattern = ".*\@.*\..*" | |
Case "integer" | |
Pattern = "^\s*[-\+]?\d+\s*$" | |
Case "double" | |
' must replace decimalchat | |
Pattern = "^\s*([-\+])?(\d+)?(\<decimalchar/>(\d+))?\s*$" | |
Case "currencyabs" | |
' must replace groupchar | |
Pattern = "^\s*([-\+])?(((\d+)\<groupchar/>)*)(\d+)\s*$" | |
Case "currency" | |
' must replace groupchar, decimalchar and digits | |
Pattern = "^\s*([-\+])?(((\d+)\<groupchar/>)*)(\d+)(\<decimalchar/>(\d{1,<digits/>}))?\s*$" | |
Case "dateymd" | |
Pattern = "^\s*((\d{4})|(\d{2}))([-./])(\d{1,2})\4(\d{1,2})\s*$" | |
Case "datemdy" | |
Pattern = "^\s*(\d{1,2})([-./])(\d{1,2})\2((\d{4})|(\d{2}))\s*$" | |
End Select | |
End Function | |
End Class | |
%> |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Escrevi algo parecido com isso em 2008. Mas foi em PHP. Criei uma classe chamada Element e fui extendendo para outras classes como P, A e etc. Criando um mecanismo para renderizar elementos na página de acordo com o estado atual. Bem legal saber que outras pessoas implementaram um conceito parecido, sendo que bem antes. http://natalphp.googlecode.com/svn-history/r78/trunk/natalphp/NatalPHP/Library/View/HTML/Element.php
Sendo que foi separado um a lógica em vários arquivos diferentes.
http://natalphp.googlecode.com/svn-history/r78/trunk/natalphp/NatalPHP/Library/CommonObjects/