<% Call fh_Main() Sub fh_Main() Dim dbPath, propFile, XML, dbFields, tableHead, allTHeads, Uploader, propValue, fieldName, fieldValue, errEvent Dim CustErr, errFlag, path, info, rowRec, objMail on error resume next Set Uploader = New FileUploader Uploader.Upload() propFile = "FormsHandler.xml" set XML = fhOpenXMLFile(Server.MapPath(propFile)) Dim comp if XML is nothing then Call fhRaiseFatalError(601) Response.End else set comp = fhGetNode(XML,,"Component", Array("name","id"), Array("formshandler", Uploader.form("componentid")), -1) end if if comp is Nothing then Call fhRaiseFatalError(400) set Xml = nothing Response.End end if dbFields = fhGetDBFields(comp) if LCase(fhGetProperty(comp,"writetodb")) = "true" then dbPath = fhGetProperty(comp, "dbpath") if dbPath = "" then 'the db path was not set fhRaiseFatalError("526") Response.End end if if not inStr(1, dbPath, "\", 1) > 0 then dbPath= Server.MapPath(dbPath) end if if fhFileExist(dbPath) then 'check if the fields are the same tableHead = fhGetLine(dbPath) if LCase(dbFields) <> LCase(tableHead) then 'create the database fhCreateDB dbPath, dbFields if (Err.Number <> 0) Then Call fhRaiseFatalError(Err.Number) set comp = nothing set Xml = nothing Response.End end if tableHead = fhGetLine(dbPath) end if else 'create the database fhCreateDB dbPath, dbFields if (Err.Number <> 0) Then Call fhRaiseFatalError(Err.Number) set comp = nothing set Xml = nothing Response.End end if tableHead = fhGetLine(dbPath) end if else tableHead = dbFields end if allTHeads = split(tableHead,",") %>
" method="post"> <% Dim File, fileFields, fileToUpload, tmpNr, filesList, i fileFields = "," for i=0 to UBound(allTHeads) fieldName = allTHeads(i) set errEvent = fhGetErrorEvent(comp, fieldName, "invalidextension" ) if not errEvent is nothing then fileFields = fileFields & allTHeads(i) & "," end if next CustErr = "" info = "" for i=0 to UBound(allTHeads) fieldName = allTHeads(i) if not inStr(1, fileFields, "," & fieldName & ",", 1) > 0 then fieldValue = fhEncodeValue(Uploader.Form(fieldName)) info = info & fieldName & " = " & fieldValue & vbCRLF call fhBuildHiddenField(fieldName, fieldValue) errFlag = fhCheckField(comp, fieldName, fieldValue) if LCase(errFlag) <> "false" then CustErr= CustErr & errFlag call fhBuildHiddenField(fieldName & "ErrImg", fhGetProperty(comp, "errormark")) end if else errFlag = false info = info & fieldName & " = " if isObject(Uploader.Files.Item(LCase(fieldName))) then info = info & Uploader.Files.Item(LCase(fieldName)).FileName & vbCRLF end if set errEvent = fhGetErrorEvent(comp,fieldName, "required" ) propValue = "" if not errEvent is nothing then propValue = fhGetProperty(errEvent, "message") if not errFlag AND Len(propValue) > 0 and propValue <> "" then if not isObject(Uploader.Files.Item(LCase(fieldName))) then errFlag = true CustErr = CustErr & "
  • " & propValue & "
  • " end if end if end if set errEvent = fhGetErrorEvent(comp, fieldName, "invalidextension" ) if not errEvent is nothing then propValue = fhGetProperty(errEvent, "fileextension") if not errFlag AND Len(propValue) > 0 and propValue <> "" _ and isObject(Uploader.Files.Item(LCase(fieldName))) then if not inStr(1, LCase(propValue), LCase(Uploader.Files.Item(LCase(fieldName)).FileExtension), 1) > 0 then errFlag = true CustErr = CustErr & "
  • " & fhGetProperty(errEvent, "message") & "
  • " end if end if end if set errEvent = fhGetErrorEvent(comp, fieldName, "filetoolarge") if not errEvent is nothing then propValue = fhGetProperty(errEvent, "maximumsize") if not errFlag AND CLng(propValue) > 0 and propValue <> "" _ and isObject(Uploader.Files.Item(LCase(fieldName))) then if Uploader.Files.Item(LCase(fieldName)).FileSize > CLng(propValue) * 1024 then errFlag = true CustErr = CustErr & "
  • " & fhGetProperty(errEvent, "message") & "
  • " end if end if end if if errFlag then call fhBuildHiddenField(fieldName & "ErrImg", fhGetProperty(comp, "errormark")) end if end if next if not Len(CustErr) > 0 then path = fhGetProperty(comp,"uploaddir") if path <> "" then if not inStr(1, path, "\", 1) > 0 then path= Server.MapPath(path) end if if LCase(fhGetProperty(comp,"writetodb")) = "true" then info = "" for i=0 to UBound(allTHeads) if Len(rowRec) > 0 then rowRec = rowRec & "," if not inStr(1, fileFields, "," & allTHeads(i) & ",", 1) > 0 then rowRec = rowRec & """" & fhEncodeValue(Uploader.Form(allTHeads(i))) & """" info = info & allTHeads(i) & " = " & _ fhEncodeValue(Uploader.Form(allTHeads(i))) & vbCRLF else if isObject(Uploader.Files.Item(LCase(allTHeads(i)))) then tmpNr = 1 fileToUpload = fhEncodeValue(Uploader.Files.Item(LCase(allTHeads(i))).FileName) if ( path <> "" ) then if fhFileExist(path & "\" & fileToUpload) then fileToUpload = Replace(fileToUpload, _ "." & Uploader.Files.Item(LCase(allTHeads(i))).FileExtension, _ CStr(tmpNr) & "." & _ Uploader.Files.Item(LCase(allTHeads(i))).FileExtension, 1, 1, 1) while fhFileExist(path & "\" & fileToUpload) fileToUpload = Replace(fileToUpload, _ CStr(tmpNr) & "." & Uploader.Files.Item(LCase(allTHeads(i))).FileExtension, _ CStr(tmpNr + 1) & "." & _ Uploader.Files.Item(LCase(allTHeads(i))).FileExtension, 1, 1, 1) tmpNr = tmpNr + 1 wend end if if Len(filesList) > 0 then filesList = filesList & "," & fileToUpload else filesList = fileToUpload end if Err.Clear() Call Uploader.Files.Item(LCase(allTHeads(i))).SaveToDisk(path, fileToUpload) if Err.number <> 0 then Call fhRaiseFatalError(Err.number) Response.End end if end if else fileToUpload = "" end if rowRec = rowRec & """" & fileToUpload & """" info = info & allTHeads(i) & " = " & fileToUpload & vbCRLF end if next Err.Clear() Call fhInsert(dbPath, CStr(rowRec)) if Err.Number <> 0 then Call fhRaiseFatalError(Err.number) Response.End end if elseif ( path <> "" ) then fileToUpload = "" For Each File In Uploader.Files.Items tmpNr = 1 fileToUpload = fhEncodeValue(File.FileName) if fhFileExist(path & "\" & fileToUpload) then fileToUpload = Replace(fileToUpload, _ "." & File.FileExtension, _ CStr(tmpNr) & "." & _ File.FileExtension, 1, 1, 1) while fhFileExist(path & "\" & fileToUpload) fileToUpload = Replace(fileToUpload, _ CStr(tmpNr) & "." & File.FileExtension, _ CStr(tmpNr+1) & "." & _ File.FileExtension, 1, 1, 1) tmpNr = tmpNr + 1 wend end if if Len(filesList) > 0 then filesList = filesList & "," & fileToUpload else filesList = fileToUpload end if info = Replace(info, File.FileName, fileToUpload,1,1) Err.Clear() Call File.SaveToDisk(path, fileToUpload) if Err.Number <> 0 then Call fhRaiseFatalError(Err.number) end if next end if if LCase(fhGetProperty(comp,"sendemail")) = "true" then if fhFileExist(Server.MapPath("FormsHandlerTemplate2.properties")) then Dim emailFileContent, fromEmail, subject, body body = fhGetTemplateValue(Server.MapPath("FormsHandlerTemplate2.properties"), "Body") body = Replace(body, "{beginiterator}{0}{enditerator}", info, 1, -1, 1) body = Replace(body, "\n", vbCRLF, 1, -1, 1) Set objMail = new CDOMail objMail.SmtpServer = fhGetProperty(comp, "smtpip") objMail.EmailTo = fhGetProperty(comp, "email") objMail.EmailFrom = fhGetTemplateValue(Server.MapPath("FormsHandlerTemplate2.properties"), "From") objMail.EmailSubject = fhGetTemplateValue(Server.MapPath("FormsHandlerTemplate2.properties"), "Subject") objMail.EmailBody = body if Len(filesList) > 0 then if instr(1, filesList,",",1) > 0 then Dim fList fList = split(filesList,",") for i=0 to UBound(fList) objMail.AttachmentsList = path & "\" & fList(i) next else objMail.AttachmentsList = path & "\" & filesList end if end if if not objMail.SendMail then Call fhRaiseFatalError(Err.number) Response.End end if Set objMail = Nothing else Call fhRaiseFatalError(110) Response.End end if end if response.write "" & vbcrlf end if call fhBuildHiddenField("Errors", CustErr) %>
    <% end sub function fhCheckField(ByVal ComponentNode, ByVal fieldName, ByVal fieldValue) On Error Resume Next fhCheckField = false 'response.write fieldName & ": " & fieldValue & "
    " propValue = "" set errEvent = fhGetErrorEvent(ComponentNode, fieldName, "required") if not errEvent is nothing then propValue = fhGetProperty(errEvent, "message") if not fhCheckField AND Len(propValue) > 0 and propValue <> "" then if not Len(fieldValue) > 0 then fhCheckField = "
  • " & propValue & "
  • " exit function end if end if end if set errEvent = fhGetErrorEvent(ComponentNode, fieldName, "short") if not errEvent is nothing then propValue = fhGetProperty(errEvent, "minimumlength") if not fhCheckField AND CLng(propValue) > 0 and propValue <> "" and fieldValue <> "" then if Len(fieldValue) < CLng(propValue) then fhCheckField = "
  • " & fhGetProperty(errEvent, "message") & "
  • " exit function end if end if end if set errEvent = fhGetErrorEvent(ComponentNode, fieldName, "long") if not errEvent is nothing then propValue = fhGetProperty(errEvent, "maximumlength") if not fhCheckField AND CLng(propValue) > 0 and propValue <> "" and fieldValue <> "" then if Len(fieldValue) > CLng(propValue) then fhCheckField = "
  • " & fhGetProperty(errEvent, "message") & "
  • " exit function end if end if end if end function %> <% CLASS CDOMail Private smtp Private smtpBck Private smtpPrt Private cdoObj Private errMsg Private customErrMsg Private fromEmail Private toEmail Private ccEmail Private bccEmail Private subject Private bodyType Private body Private smtpAuth 'sets if smtp server require authenticaion or not [0|1] Private smtpUName Private smtpPass Private attachArray Private iBodyParts 'class constructor Private Sub Class_Initialize() errMsg = "" On Error Resume Next set cdoObj = Server.CreateObject("CDO.Message") if Err.Number <> 0 then errMsg = "Could not intialize the 'CDO.Message' object." & vbCrLf & "
    Reason: " & Err.Description customErrMsg = "Could not intialize the 'CDO.Message' object." Err.Clear set cdoObj = nothing end if toEmail ="" fromEmail = "" ccEmail = "" bccEmail = "" smtp = "localhost" smtpBck = "localhost" smtpPrt = "25" subject = "" bodyType = "text" body = "" smtpAuth = 0 ReDim attachArray(0) attachArray(0) = "" ReDim iBodyParts(0) iBodyParts(0) = "" End Sub 'class destructor Private Sub Class_Terminate() set cdoObj = nothing End Sub Public function AddAttachment(ByVal fileContent, ByVal CType, ByVal FileName) Dim iBp, flds, stm, s, s1 set iBp = cdoObj.Attachments.Add Set flds = iBp.Fields with flds .Item("urn:schemas:mailheader:content-type") = CType & "; name=" & FileName if ( CType = "text/plain" ) then .Item("urn:schemas:mailheader:content-transfer-encoding") = "7bit" elseif ( inStr(1,Ctype, "text/") ) then .Item("urn:schemas:mailheader:content-transfer-encoding") = "quoted-printable" else .Item("urn:schemas:mailheader:content-transfer-encoding") = "base64" end if .Item("urn:schemas:mailheader:content-disposition") = "attachment; fileName=" & FileName .Update end with set flds = nothing if ( inStr(1, CType, "text/") ) then set stm = iBp.GetDecodedContentStream else set stm = iBp.GetEncodedContentStream fileContent = Base64Encode(fileContent) end if stm.WriteText fileContent stm.Position = 0 s = stm.ReadText(20) stm.Flush set Stm = Nothing End function Public function SendMail() Dim configurationObj, fieldsObj, i On Error Resume Next if isNotEmailAddress(toEmail) then errMsg = "The 'To' is not a valid email address." customErrMsg = "The 'To' which is '" & toEmail & "' is not a valid email address." Call Err.Raise(202, customErrMsg, "(" & err.Number & ") " & err.Description) Err.Clear() exit function end if if Trim(fromEmail) = "" then errMsg = "The 'From' cannot be empty." customErrMsg = "The 'From' cannot be empty." Call Err.Raise(202, customErrMsg, "(" & err.Number & ") " & err.Description) Err.Clear() exit function end if Set configurationObj = CreateObject("CDO.Configuration") Set fieldsObj = configurationObj.Fields With fieldsObj .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtpPrt .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtp .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10 if ( smtpAuth ) then .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = smtpUName .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = smtpPass end if .Update End With Set fieldsObj = nothing if not cdoObj is nothing then With cdoObj set .Configuration = configurationObj .From = fromEmail .To = toEmail if ( Trim(ccEmail) <> "") then .CC = ccEmail if ( Trim(bccEmail) <> "") then .BCC = bccEmail .Subject = subject select case LCase(Trim(bodyType)) case "text" .TextBody = body case "html" .HtmlBody = body case else .HtmlBody = body end select for i=0 to UBound(attachArray) if attachArray(i) <> "" then .AddAttachment(attachArray(i)) if Err.number <> 0 then Err.Clear end if next Err.Clear() .Send if ( Err.Number <> 0 ) then errMsg = "the error occured trying to sent the email through this server: " _ & smtp & vbCrLf & "
    Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description customErrMsg = "An error occured trying to send the email." Err.Clear() Set fieldsObj = configurationObj.Fields With fieldsObj .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtpPrt .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpBck .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10 if ( smtpAuth ) then .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = smtpUName .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = smtpPass end if .Update End With Set fieldsObj = nothing Set .Configuration = configurationObj .Send() if ( Err.Number <> 0 ) then 'errMsg = "the error occured trying to sent the email through this server: " _ ' & smtp & vbCrLf & "
    Error Number: " & Err.Number & vbCrLf & "
    Error Description: " & Err.Description customErrMsg = "An error occured trying to send the email." SendMail = false Call Err.Raise(201, customErrMsg, "(" & err.Number & ") " & err.Description) set configurationObj = nothing exit function end if end if End With end if set configurationObj = nothing SendMail = true End function Private function isNotEmailAddress(str) isNotEmailAddress = false if ( isNull(str) or isEmpty(str) or Trim(str) = "" ) then isNotEmailAddress = true End function ' Functions for encoding string to Base64 Function Base64Encode(inData) Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim cOut, sOut, I 'For each group of 3 bytes For I = 1 To Len(inData) Step 3 Dim nGroup, pOut, sGroup 'Create one long from this 3 bytes. nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _ &H100 * MyASC(Mid(inData, I + 1, 1)) + MyASC(Mid(inData, I + 2, 1)) 'Oct splits the long To 8 groups with 3 bits nGroup = Oct(nGroup) 'Add leading zeros nGroup = String(8 - Len(nGroup), "0") & nGroup 'Convert To base64 pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1) 'Add the part To OutPut string sOut = sOut + pOut 'Add a new line For Each 76 chars In dest (76*3/4 = 57) 'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf Next Select Case Len(inData) Mod 3 Case 1: '8 bit final sOut = Left(sOut, Len(sOut) - 2) + "==" Case 2: '16 bit final sOut = Left(sOut, Len(sOut) - 1) + "=" End Select Base64Encode = sOut End Function Function MyASC(OneChar) If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar) End Function ' Get/Let properties Public Property Get SmtpServer() SmtpServer = smtp End Property Public Property Let SmtpServer(ByVal s) smtp = s End Property Public Property Get SmtpBackupServer() SmtpBackupServer = smtpBck End Property Public Property Let SmtpBackupServer(ByVal s) smtpBck = s End Property Public Property Get SmtpPort() SmtpPort = smtpPrt End Property Public Property Let SmtpPort(ByVal s) smtpPrt = s End Property Public Property Get EmailFrom() EmailFrom = fromEmail End Property Public Property Let EmailFrom(ByVal s) fromEmail = s End Property Public Property Get EmailTo() EmailTo = toEmail End Property Public Property Let EmailTo(ByVal s) toEmail = s End Property Public Property Get EmailCC() EmailCC = ccEmail End Property Public Property Let EmailCC(ByVal s) ccEmail = s End Property Public Property Get EmailBCC() EmailBCC = bccEmail End Property Public Property Let EmailBCC(ByVal s) bccEmail = s End Property Public Property Get EmailSubject() EmailSubject = subject End Property Public Property Let EmailSubject(ByVal s) subject = s End Property Public Property Get EmailBodyType() EmailBodyType = bodyType End Property Public Property Let EmailBodyType(ByVal s) bodyType = s End Property Public Property Get EmailBody() EmailBody = body End Property Public Property Let EmailBody(ByVal s) body = s End Property Public Property Get SMTPAuthenticate() SMTPAuthenticate = smtpAuth End Property Public Property Let SMTPAuthenticate(ByVal b) smtpAuth = CLng(b) End Property Public Property Get SMTPUserName() SMTPUserName = smtpUName End Property Public Property Let SMTPUserName(ByVal s) smtpUName = s End Property Public Property Get SMTPPassword() SMTPPassword = smtpPass End Property Public Property Let SMTPPassword(ByVal s) smtpPass = s End Property Public Property Get AttachmentsList() AttachmentsList = attachArray End Property Public Property Let AttachmentsList(ByVal s) if attachArray(UBound(attachArray)) <> "" then ReDim Preserve attachArray( UBound(attachArray) + 1 ) end if attachArray(UBound(attachArray)) = s End Property Public Property Get ErrorMessage() ErrorMessage = errMsg End Property Public Property Get CustomErrorMessage() CustomErrorMessage = customErrMsg End Property END CLASS %>