<%@LANGUAGE="VBSCRIPT"%>
<%
OPTION EXPLICIT
Response.Buffer = true
'
'Generate the response and email the submission
'Assume webserver with asp and email but no database
'Set iEmail global variables
DIM MailMethod, SMTPServer, SMTPMailPickupDirectory, SMTPServerPort
'Global Settings (this marker may be used by the include directive to write out a master include)
MailMethod=1
'SMTPServer="10.4.66.80"
'SMTPMailPickupDirectory="D:\Inetpub\mailroot\pickup"
'SMTPServerPort="25"
SMTPServer="203.10.224.148"
SMTPMailPickupDirectory="D:\Inetpub\mailroot\pickup"
SMTPServerPort="25"
'EOGlobal Settings
DIM sAddress, sSubject, sBody, fld
sAddress=Request.QueryString("e1")&"@"&Request.QueryString("e2")
sSubject=Request.QueryString("subj")
sBody="Form Submitted "&FormatDateTime(Now, 1)&" "&FormatDateTime(Now, 3)&vbCRLF&vbCRLF
IF request.form("AllFields")<>"" THEN
'this is the new way of building the body in field order, but keeping the old way for backwards compatability
dim aFields, aPrompts, iField
aFields = split(request.form("AllFields"), ",")
aPrompts = split(request.form("AllPrompts"), ",")
For iField = 0 to uBound(aFields)
IF Not(fieldIsSystemField(aFields(iField))) THEN
IF Len(aPrompts(iField))>0 THEN
sBody=sBody&aPrompts(iField)&" = "&Request.Form(aFields(iField))&vbCRLF&vbCRLF
ELSE
sBody=sBody&aFields(iField)&" = "&Request.Form(aFields(iField))&vbCRLF&vbCRLF
END IF
IF Request.Form("rememberThese")<>"" THEN
Response.Cookies(aFields(iField))=Request.Form(aFields(iField))
Response.Cookies(aFields(iField)).Expires=(Date+365)
'Response.Write "Setting Cookie : "&fld&" "
END IF
IF InStr(1,sAddress,"<"&aFields(iField)&">",1)>0 THEN
sAddress=Replace(sAddress,"<"&aFields(iField)&">",Request.Form(aFields(iField))&"",1,-1,1)
END IF
END IF
Next
ELSE
For Each fld In Request.Form
IF Not(fieldIsSystemField(fld)) THEN
sBody=sBody&fld&" = "&Request.Form(fld)&vbCRLF&vbCRLF
IF Request.Form("rememberThese")<>"" THEN
Response.Cookies(fld)=Request.Form(fld)
Response.Cookies(fld).Expires=(Date+365)
'Response.Write "Setting Cookie : "&fld&" "
END IF
END IF
Next
END IF
sBody=sBody&vbCRLF&vbCRLF
sBody=sBody&"The Session number is "&Session.SessionID&vbCRLF
'sBody=sBody&"(NB: if there are multiple submissions from the same session, this would indicate the user has probably unintentionally submitted the form multiple times."&vbCRLF
sBody=sBody&"The IP was: "&Request.ServerVariables("LOCAL_ADDR")
IF Len(Request.ServerVariables("HTTP_X_FORWARDED_FOR"))>0 THEN
sBody=sBody&"The originating IP was (before routing): "&Request.ServerVariables("HTTP_X_FORWARDED_FOR")
END IF
'Do the email after the database save - we want the refID
'SendEmail "ComWebForms", sAddress, null, sSubject, sBody, false
'----------Access Database Save
DIM AccessFile, AccessPhysFile, fso, sAccessConn, oAccessConn, oRS, sSQL
DIM sFormName, ReferenceID
AccessFile="Data/FormData.mdb"
ReferenceID=""
Set fso=CreateObject("Scripting.FileSystemObject")
AccessPhysFile=Server.MapPath(AccessFile)
IF fso.FileExists(AccessPhysFile) THEN
sAccessConn = "PROVIDER=MICROSOFT.JET.OLEDB.4.0;DATA SOURCE=" & AccessPhysFile
Set oAccessConn=Server.CreateObject("ADODB.Connection")
oAccessConn.Open sAccessConn
IF InStr(sSubject,"(")>0 AND InStr(sSubject,")")>0 THEN
'this as original way Form (formname) Submission
sFormName=Mid(sSubject,InStr(sSubject,"(")+1)
sFormName=Left(sFormName,InStr(sFormName,")")-1)
ELSE
sFormName=sSubject
END IF
sSQL="CREATE TABLE ["&sFormName&"] ("
For Each fld In Request.Form
sSQL=sSQL&"["&fld&"] memo,"
Next
sSQL=Left(sSQL,Len(sSQL)-1) &")"
On Error Resume Next
oAccessConn.Execute sSQL
On Error Goto 0 : Err.Clear
sSQL="["&sFormName&"]"
Set oRS=Server.CreateObject("ADODB.Recordset")
Const adCmdTable = &H0002
oRS.Open sSQL, oAccessConn, 1, 2, adCmdTable
oRS.AddNew
For Each fld In Request.Form
On Error Resume Next
oRS(fld)=Request.Form(fld)
On Error Goto 0 : Err.Clear
Next
oRS.Update
On Error Resume Next
ReferenceID=oRS("RefID")
On Error Goto 0 : Err.Clear
oRS.Close: Set oRS=Nothing
Set oAccessConn=Nothing
END IF
DIM ReferenceMsg : ReferenceMsg=""
IF ReferenceID <> "" THEN
ReferenceMsg="
Your Reference Number is "&ReferenceID&"
"
sSubject=sSubject&" Ref#"&ReferenceID
END IF
DIM sFromImpersonate
'sFromImpersonate=Request("email")
'IF sFromImpersonate="" THEN
sFromImpersonate="webmaster@defence.gov.au"
'23Nov07 Added this IF block - IF from address is in the to address
' then remove that address from the to and send another email to just that to with the from being the first part of the to
'eg the original from: to: helpdesk@compucraft.com.au;;
'becomes from: to: helpdesk@compucraft.com.au;
' and from: helpdesk@compucraft.com.au to:
IF InStr(1,sAddress,";"&sFromImpersonate,1)>0 THEN
DIM sNewAddress, sNewImpersonate
sNewImpersonate=Left(sAddress,InStr(1,sAddress,";",1)-1)
sNewAddress=sFromImpersonate
SendEmail sNewImpersonate, sNewAddress, null, sSubject, sBody, false
'remove the addrress
sAddress=Replace(sAddress,";"&sFromImpersonate,"",1,-1,1)
END IF
SendEmail sFromImpersonate, sAddress, null, sSubject, sBody, false
%>
Form Submitted
Data successfully submitted
<%= ReferenceMsg %>
<%
'--------------------FUNCTIONS/SUBS----------------------------------------------------
FUNCTION FieldIsSystemField(field)
DIM bResult: bResult=false
bResult=bResult OR (field="AllFields")
bResult=bResult OR (field="AllPrompts")
bResult=bResult OR (field="doSave")
bResult=bResult OR (field="doReset")
bResult=bResult OR (field="doPrint")
bResult=bResult OR (field="Authenticated")
bResult=bResult OR (Left(field,6)="DataID")
bResult=bResult OR ((Left(field,6)="cwForm") AND (Right(field,6)="DataID"))
FieldIsSystemField=bResult
END FUNCTION
'---------------------------------------------------------------------------
'Below is a copy of iEmail.asp
'
'this global variable was introduced so as to not add a var within the SUB call that may break other parts
'if set, will attempt to set expiry on CDO.Message - this is only good for Outlook2003
DIM gvEmailExpiryDate: gvEmailExpiryDate=""
SUB SendEmail(sFrom, sTo, sBCC, sSubject, sBody, bSendAsHTML)
CONST CDOBodyFormatHTML=0
DIM MyMail, bErrorHandled
'response.write SMTPMailPickupDirectory: response.end
IF MailMethod=0 THEN
Set myMail=Server.CreateObject ("CDONTS.Newmail")
IF IsNull(sFrom) then myMail.From=sSenderEmail else myMail.From=sFrom end if
IF sTo = "" or isnull(sTo) THEN
sTo = sFrom
END IF
IF Not(sTo="" OR IsNull(sTo)) THEN
myMail.To=sTo
IF Not(IsNull(sBCC) OR IsEmpty(sBCC) OR (sBCC="")) THEN myMail.BCC=sBCC
myMail.Subject=sSubject
IF bSendAsHTML THEN
myMail.BodyFormat=CDOBodyFormatHTML
END IF
myMail.Body=sBody
myMail.Send
END IF
ELSE
DIM objConfiguration, colFields
'See http://www.paulsadowski.com/WSH/cdo.htm
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2 'Must use this to use Delivery Notification
Const cdoAnonymous = 0
Const cdoBasic = 1 ' clear text
Const cdoNTLM = 2 'NTLM
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 'Success, failure or delay
CONST cdoSendUsingMethod="http://schemas.microsoft.com/cdo/configuration/sendusing"
CONST cdoSMTPServerPickUpDirectory="http://schemas.microsoft.com/cdo/configuration/smtpserverpickupdirectory"
'This program works in defence - yet it theirs MUST be a later version
'This is because cdoSendUsingMethod cdoSMTPServerPickUpDirectory ARE NOT defined.
'Leave option explicit on next time
On Error Resume Next
Set myMail=Server.CreateObject ("CDO.Message")
IF Err.Number<>0 THEN
Response.Write "
An error has occurred attempting to send mail. "
Response.Write "The server could not create the mail object. "
Response.Write "This is probably due to an error in configuration or the mail server may not be enabled. "
Response.Write "The server error message is:
"
Response.Write Err.Number&" "
Response.Write "
"&Err.Description&"
"
Response.End
END IF
On Error GoTo 0
'create a new message configuration object
Set objConfiguration = Server.CreateObject("CDO.Configuration")
'get a reference to the fields of the configuration object
Set colFields = objConfiguration.Fields
IF MailMethod=1 and false THEN
colFields(cdoSendUsingMethod) = cdoSendUsingPickup
colFields(cdoSMTPServerPickUpDirectory) = SMTPMailPickupDirectory
ELSEIF MailMethod=1 THEN
'response.write SMTPServer&" "&SMTPServerPort: response.end
colFields(cdoSendUsingMethod) = cdoSendUsingPort
colFields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
colFields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPServerPort
END IF
colFields.Update 'save the updated configuration fields values
'Cant seem to get this going!!
'IF gvEmailExpiryDate<>"" THEN myMail.timeexpired=gvEmailExpiryDate
'IF gvEmailExpiryDate<>"" THEN response.write "%%%%%%%"&myMail.Fields(1376320) '=null
IF IsNull(sFrom) then
myMail.From = sSenderEmail
else
myMail.From = sFrom
end if
IF sTo = "" or isnull(sTo) THEN
sTo = sFrom
END IF
'Response.Write "TO="&sTo&br
'Response.Write "FROM="&sFrom&br
'Response.End
Set myMail.Configuration = objConfiguration 'the config object we've just created
'sBCC=Trim(Left(Mid(sBCC,2),Len(sBCC)-3))
'sBCC="dave.mcrae@compucraft.com.au; davemcrae999@hotmail.com"
'sBCC="dave.mcrae@compucraft.com.au; adam.pollard@compucraft.com.au"
'sBCC="": sTo="davemcrae999@hotmail.com"
'Response.Write "To="&sTo&" "&"BCC="&sBCC&" "&IsNull(sBCC): response.end
IF Not(sTo="" OR IsNull(sTo)) THEN
myMail.To = sTo
IF Not(sBCC="" OR IsNull(sBCC)) THEN
'Even if Forms explicitly passes a NULL BCC, some environments still executes this line - thus failing
On Error Resume Next
myMail.BCC = sBCC
On Error Goto 0
END IF
myMail.Subject=sSubject
IF bSendAsHTML THEN
myMail.HTMLBody=sBody
ELSE
myMail.TextBody=sBody
END IF
'On Error Resume Next - doing this and then gogo 0 to re-raise unhandled error does not work (goto0 does an err.clear)
Err.Clear
MailSendErrorHandling myMail, bErrorHandled
IF Not(bErrorHandled) AND (Err.Number<>0) THEN
Err.Raise Err.Number, Err.source, Err.description, Err.helpfile, Err.helpcontext
END IF
'response.write Err.Number&" error occured------------" ': response.end
END IF
END IF
Set myMail = Nothing 'release the object reference
END SUB
FUNCTION emailErrorMessage(bHandled)
DIM sResult
sResult="
An Email error occured
The error reported was: "
sResult=sResult&Err.Number&" (0x" & Hex(Err.Number) & ")"&" "
sResult=sResult&Err.Description&" "
bHandled=true
emailErrorMessage=sResult
END FUNCTION
SUB MailSendErrorHandling(myMail,bHandled)
bHandled=false
On Error Resume Next
myMail.Send
IF Err.Number<> 0 THEN
IF (Err.Number=-2147220977) AND (InStr(1,Err.Description,"Unable to relay",1)>0) THEN
Response.Write emailErrorMessage(bHandled)
Response.Write "The SMTP Relay will have to be configured to allow external mail.
"
END IF
IF Not(bHandled) THEN
' Response.Write "An Email error occured
The error reported was: "
' Response.Write Err.Number&" (0x" & Hex(Err.Number) & ")"&" "
' Response.Write Err.Description&" "
response.write "*"&Err.Number
'On Error Goto 0 : Err.Raise Err.Number, etc - NB: will not work - the Calle "On Error Resume Next" suppresses this
END IF
END IF
END SUB
%>