[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 367
  • Last Modified:

how to setup aspformmail on local intranet

I am running exchange 2003 on our company intranet and want to use aspformmail to gather information from employees at the company.
I use the aspformmail on our web host site and it works great, but can not get it to work on local intranet site.
%
'****** aspFormMail V2.31 ******
'    http://www.pd9soft.com/
'******                   ******
 
Dim strMailServer, arrAllowedSites, strEmailComponent, strDefaultFromAddress, strDefaultToAddress
Dim strMissing, arrRequired, strRequired, intMissing, strMessage, strTitle, strReferer
Dim blnBadReferer, strNeedEmail, blnValidated, strFromEmail, strToEmail, strRedirectTo
Dim blnPrintBlank, arrConfig, strConfig, strBody, strHowSort, arrUnsorted, arrSorted, strElement
Dim intDelimiter, strItem, strValue, strResult, intStart, objMail, blnDefaultToEmail
Dim blnUseDefault
 
'****** User Configuration *****
 
'The mail server for your site
strMailServer = "mts-exch1.metrotransit.com"
 
'A list of allowed referers (sites that can use this script)
arrAllowedSites = Array("http://www.thewavetransit.com/","http://mts-exch1/intranet/"
			
 
'The email component to use
'strEmailComponent = "CDOSyS"
 
'The default 'from' address to use if the user does not enter one
strDefaultFromAddress = "drowell@thewavetransit.com"
 
'The default 'to' address - this can be overridden on any referring page
strDefaultToAddress = "drowell@thewavetransit.com"
 
'If there is no referrer, send to default email address?
blnDefaultToEmail = True
 
'***** End Of User Configuration *****
 
 
'Check that all the required fields have been filled in
If Request("Required") <> "" Then
 
  'The start of the string to print if some are missing
  strMissing = "The following fields need to be filled out:<ul type=disc>"
 
  'Loop through each required field and check it has been filled in
  arrRequired = Split(Trim(Request("Required")), ",")
  For Each strRequired In arrRequired
    If Trim(Request(strRequired)) = "" Then
      Select Case UCase(strRequired)
        Case "FROMEMAIL"
          strRequired = "Your email address"
      End Select
      strMissing = strMissing & "<li>" & strRequired & "<br>"
      intMissing = 1
    End If
  Next
 
  strMissing = strMissing & "</ul>"
 
  'Display the error message if neccessary
  If intMissing = 1 Then
    ReportError strMissing, "Required fields not filled out"
  End If
 
End If
 
'Check the referer is a valid site
strReferer = UCase(Request.ServerVariables("HTTP_REFERER"))
blnBadReferer = True
 
'Some firewalls (Norton's Personal Firewall, for instance) strip out the referrer
If strReferer = "" Then
  If blnDefaultToEmail Then
    'If the option is turned on, then use the default address
    blnBadReferer = False
    blnUseDefault = True
  End If
End If
For Index = 0 To UBound(arrAllowedSites)
  If UCase(Left(strReferer, Len(arrAllowedSites(Index)))) = UCase(arrAllowedSites(Index)) Then
    blnBadReferer = False
  End If
Next
 
'If the referer is invalid, notify the user
If blnBadReferer Then
  strMessage = "The site which refered you to this script is not allowed access to this script."
  strMessage = strMessage & "<br>A possible solution is lowering the privacy levels on your "
  strMessage = strMessage & "firewall, or stopping it, while you fill in this form."
  strMessage = strMessage & "<br>Please contact the webmaster of the site."
  ReportError strMessage, "Bad Referer"
End If
 
'If a valid email address is needed
strNeedEmail = Request("NeedEmail")
if strNeedEmail = "" Then strNeedEmail = "No"
 
'If a valid address is needed, check the given address
'Otherwise, just replace it with the default if the length is zero
Select Case UCase(strNeedEmail)
  Case "YES"
 
    'If no email address was supplied
    If Len(Request("FromEmail")) = 0 Then
      strMessage = "You must supply an email address.<br><br>Please use the Back button on your browser to return and correct this."
      ReportError strMessage, "Invalid Email Address"
    End If
 
    'Check if the address is valid; the function will give the error page if it is invalid
    'i.e. if it returns to here, it is valid
    CheckEmail(Request("FromEmail"))
    strFromEmail = Request("FromEmail")
 
  Case "NO"
 
    If Len(Request("FromEmail")) = 0 Then
      strFromEmail = strDefaultFromAddress
    Else
      strFromEmail = Request("FromEmail")
    End If
 
End Select
 
'Check that there is somewhere for the email to go
strToEmail = Request("ToEmail")
If Len(strToEmail) = 0 Then strToEmail = strDefaultToAddress
If blnUseDefault Then strToEmail = strDefaultToAddress
If Len(strToEmail) = 0 Then
  strMessage = "The email address to send this information to is missing.<br>Please inform the administrator of this website."
  ReportError strMessage, "No email address"
End If
 
'Make sure there is a redirection URL
strRedirectTo = Request("RedirectURL")
If Len(strRedirectTo) = 0 Then
  strMessage = "A redirection URL was not supplied.<br>Please inform the webmaster of this site."
  ReportError strMessage, "Need Redirection URL"
End If
 
'Send the form
SendForm
 
 
Sub SendForm()
'Description: Uhhhhh... it, well, processes and sends the data
 
'Whether or not to send blank fields
Select Case Left(UCase(Request("Print_Blank")), 1)
  Case "Y"
    blnPrintBlank = True
  Case Else
    blnPrintBlank = False
End Select
 
'If wanted, adds the config variables to the message
If Request("Print_Config") <> "" Then
  arrConfig = Split(Request("Print_Config"), ",")
  For Each strConfig In arrConfig
    strBody = strBody & Trim(strConfig) & ": " & Trim(Request(strConfig)) & vbCrLf
  Next
End If
 
'Perform the sorting however the user specified
strHowSort = Request("Sort")
If Len(strHowSort) = 0 Then strHowSort = "Formorder"
 
If UCase(strHowSort) = "ALPHABETICAL" Then
    'Sort alphabetically
 
    'Get the raw data and size the array for the final data appropriately
    arrUnsorted = Split(Request.Form, "&")
    ReDim arrSorted(UBound(arrUnsorted))
 
    'Gets the field names - i.e. without the submitted data - and places them in the second array
    For I = 0 To UBound(arrUnsorted)
      strElement = arrUnsorted(I)
      intDelimiter = InStr(strElement, "=")
      If intDelimiter = 0 Then intDelimiter = Len(strElement)
      arrSorted(I) = Left(strElement, intDelimiter - 1)
    Next
 
    'Sorts the fieldnames alphabetically
    QuickSort arrSorted, 0, UBound(arrSorted)
 
    'Then adds the field names and their respective entries, except for config entries, to the
    'body of the message
    For I = 0 To UBound(arrSorted)
      strItem = UCase(arrSorted(I))
      strValue = Request(strItem)
 
      If ((Len(strValue) <> 0 Or blnPrintBlank) And strItem <> "FROMEMAIL" _
       And strItem <> "TOEMAIL" And strItem <> "FROMNAME" And strItem <> "TONAME" _
       And strItem <> "PRINT_CONFIG" And strItem <> "REDIRECTURL" And strItem <> "PRINT_BLANK" _
       And strItem <> "ENV_REPORT" And strItem <> "EMAILSUBJECT" And strItem <> "SORT" _
       And strItem <> "REQUIRED" And strItem <> "NEEDEMAIL" And strItem <> "SUBMIT") Then
         strBody = strBody & strItem & ": " & Canonize(strValue) & vbCrLf
      End If
    Next
 
ElseIf UCase(strHowSort) <> "ALPHABETICAL" And UCase(strHowSort) <> "FORMORDER" Then
    'Sort in the order the user wanted
    arrSorted = Split(Request("Sort"), ",")
    For Each strData In arrSorted
      strBody = strBody & UCase(Trim(strData)) & ": " & Trim(Request(strData)) & vbCrLf
    Next
 
Else
    'Print them in the default order
    'Unfortunately, ASP does not include an easy way to tell the order in which they were
    'submitted, so we have to use the raw data to find out.
 
    arrUnsorted = Split(Request.Form, "&")
    For I = 0 To UBound(arrUnsorted)
      strElement = arrUnsorted(I)
      intDelimiter = InStr(strElement, "=")
      strItem = UCase(Left(strElement, intDelimiter - 1))
      strValue = Mid(strElement, intDelimiter + 1)
 
      If ((Len(strValue) <> 0 Or blnPrintBlank) And strItem <> "FROMEMAIL" _
       And strItem <> "TOEMAIL" And strItem <> "FROMNAME" And strItem <> "TONAME" _
       And strItem <> "PRINT_CONFIG" And strItem <> "REDIRECTURL" And strItem <> "PRINT_BLANK" _
       And strItem <> "ENV_REPORT" And strItem <> "EMAILSUBJECT" And strItem <> "SORT" _
       And strItem <> "REQUIRED" And strItem <> "NEEDEMAIL" And strItem <> "SUBMIT") Then
         strBody = strBody & strItem & ": " & Canonize(strValue) & vbCrLf
      End If
    Next
 
End If
 
'If the user wanted the server variables printed, do so now
If Left(UCase(Trim(Request("Env_Report"))), 1) = "Y" Then
  strBody = strBody & vbCrLf & "-- Enviroment Variables" & vbCrLf
  strBody = strBody & "Remote Address: " & Request.ServerVariables("REMOTE_ADDR") & vbCrLf
  strBody = strBody & "Remote Host: " & Request.ServerVariables("REMOTE_HOST") & vbCrLf
  strBody = strBody & "Referring URL: " & Request.ServerVariables("HTTP_REFERER") & vbCrLf
  strBody = strBody & "User Name: " & Request.ServerVariables("REMOTE_USER") & vbCrLf
  strBody = strBody & "Browser Type: " & Request.ServerVariables("HTTP_USER_AGENT") & vbCrLf
End If
 
'*** Anonymous To-Email Configuration ***
If UCase(strToEmail) = "USER1" Then
  strToEmail = "user1@yoursite.com"
ElseIf UCase(strToEmail) = "USER2" Then
  strToEmail = "user2@yoursite.com"
End If
'*** End Of Anonymous To-Email Configuration ***
 
 
'Configure the email component and then send the message
Select Case UCase(strEmailComponent)
 
  Case "JMAIL"
    'We are using the JMail component, available at http://www.dimac.net/
 
    Set objMail = Server.CreateObject("JMail.SMTPMail")
 
    objMail.Sender          = strFromEmail
    objMail.Charset         = "UTF-8"
    objMail.SenderName      = Request("FromName")
    objMail.AddRecipientEX strToEmail, Request("ToName")
    objMail.Subject         = Request("EmailSubject")
    objMail.LazySend        = True
    objMail.ServerAddress   = strMailServer
    objMail.Body            = strBody
 
    objMail.Execute
 
  Case "JMAIL4"
    'We are using the JMail component, available at http://www.dimac.net/
 
    Set objMail = Server.CreateObject("JMail.Message")
 
    objMail.Charset    = "UTF-8"
    objMail.Logging    = False
    objMail.Silent     = True
    objMail.From       = strFromEmail
    objMail.FromName   = Request("FromName")
    objMail.Subject    = Request("EmailSubject")
    objMail.Body       = strBody
    objMail.AddRecipient sToEmail, request("ToName")
 
    objMail.Send(strMailServer)
 
  Case "ASPEMAIL"
    'Using the ASPEmail component, available at http://www.aspemail.com
 
    Set objMail      = Server.CreateObject("Persits.MailSender")
 
    objMail.Host     = strMailServer
    objMail.From     = strFromEmail
    objMail.FromName = Request("FromName")
    objMail.AddAddress strToEmail, request("ToName")
    objMail.Subject  = Request("EmailSubject")
    objMail.Body     = strBody
 
    objMail.Send
 
  Case "CDONTS"
    'Send using the CDONTS component
 
    Set objMail     = Server.CreateObject("CDONTS.NewMail")
 
    objMail.MailFormat = 0
    objMail.SetLocaleIDs(65001)
    objMail.From    = strFromEmail
    objMail.To      = strToEmail
    objMail.Subject = Request("EmailSubject")
    objMail.Body    = strBody
 
    objMail.Send
 
    Set objMail = Nothing
 
  Case "CDOSYS"
    'Use the CDOSYS component
 
    dim iConf, Flds, objNewMail
    set iConf = Server.CreateObject("CDO.Configuration")
    set Flds = iConf.Fields
 
    'Set and update fields properties
    Flds("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer
    Flds("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    Flds("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 ' cdoSendUsingPickup=1; cdoSendUsingPort=2
    ' Flds("http://schemas.microsoft.com/cdo/configuration/smtpserverpickupdirectory") = dictConfiguration("sCDOPICKUPFOLDER")
    Flds("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
    Flds.Update
 
    Set objNewMail = Server.CreateObject("CDO.Message")
    objNewMail.bodypart.Charset = "utf-8"
    Set objNewMail.Configuration = iConf
 
    'Format and send message
    Err.Clear
    objNewMail.To = strToEmail
    objNewMail.From = strFromEmail
    objNewMail.Subject = Request("EmailSubject")
    objNewMail.TextBody = strBody
    objNewMail.Send
    set objNewMail = Nothing
    set Flds = Nothing
    set iConf = Nothing
End Select
 
Response.Redirect strRedirectTo
 
End Sub
 
 
Sub ReportError(strMessage, strTitle)
'Description: Reports any errors in the form back to the user
  %>
<html>
 
<head>
<title><%=strTitle%></title>
 
<!--#include file="mailheader.inc" -->
 
<%=strMessage%>
<br>
 
<!--#include file="mailfooter.inc" -->
  <%
  Response.End
 
End Sub
 
Function CheckEmail(strEmailToCheck)
'Description: Tries to guess if an e-mail address is valid.
 
  blnValidated = True
 
  If InStr(strEmailToCheck, "@") = 1 Then '(the '@' is in the first position)
    blnValidated = False
    strWhatsWrong = "The '@' in the address you specified is in the first position.<br><br>Please use the Back button of your browser to return and correct this."
  End If
 
  If blnValidated Then
    If InStr(strEmailToCheck, "@") = Len(strEmailToCheck) then '(The '@' is in the last position)
      blnValidated = False
      strWhatsWrong = "The '@' in the address you specified is in the last position.<br><br>Please use the Back button of your browser to return and correct this."
    End If
  End If
 
  If blnValidated Then
    J = 0
    For I = 1 To Len(strEmailToCheck)
      If Mid(strEmailToCheck, I, 1) = "@" Then  'there is a '@' in the address at this position
        J = J + 1
        K = I
      End If
    Next
 
    Select Case J
      Case 0
        blnValidated = False
        strWhatsWrong = "There is no '@' in the address you specified.<br><br>Please use the Back button of your browser to return and correct this."
      Case 1
        'Need to have this otherwise the Case Else includes J = 1
        strWhatsWrong = strWhatsWrong
      Case Else
        blnValidated = False
        strWhatsWrong = "There are too many '@' symbols in the address you supplied.<br><br>Please use your browser's back button to correct this."
    End Select
  End If
 
  If blnValidated Then
    J = 0
    For I = 1 To Len(strEmailToCheck)  'K is the position of the '@' (from above check)
      If Mid(strEmailToCheck, I, 1) = "." Then  'there is a period after the '@'
        J = 1
      End If
    Next
 
    If J = 0 Then
      blnValidated = False
      strWhatsWrong = "There is no period after the '@' in the address you specified.<br><br>Please use the Back button of your browser to return and correct this."
    End If
  End If
 
  If blnValidated Then
    For I = K To Len(strEmailToCheck)
      If Mid(strEmailToCheck, I, 1) = "." Then  'there is a period at this spot
        J = I
      End If
    Next
 
    L = Len(strEmailToCheck) - 2
    If J > L Then     'the last period is less than two places before the end of the address
      blnValidated = False
      strWhatsWrong = "The extension after the last period in the email address you specified is less than 2 letters long.<br><br>Please use the Back button of your browser to return and correct this."
    End If
  End If
 
  If blnValidated Then
    K = K + 1
    If Mid(strEmailToCheck, K, 1) = "." Then  'there is a period immediately after the '@'
      blnValidated = false
      strWhatsWrong = "The first character after the '@' in the email address you specified is a period.<br><br>Please use the Back button on your browser to return and correct this."
    End If
  End If
 
  If Not blnValidated Then ReportError strWhatsWrong, "Invalid Email Address"
 
End Function
 
 
Function QuickSort(vArray, LowBound, HighBound)
'Description: Sorts the given array into alphabetical order
 
  Dim lTmpLow, lTmpHi, iMiddlePos, vTempVal, vTmpHold
 
  lTmpLow = cInt(LowBound)
  lTmpHi  = cInt(HighBound)
  if HighBound <=LowBound or not IsArray(vArray) then Exit Function
 
  iMiddlePos = (LowBound + HighBound) \ 2
 
  vTempVal = vArray(iMiddlePos)
 
  Do While (lTmpLow <= lTmpHi)
 
     Do While (vArray(lTmpLow) < vTempVal And lTmpLow < HighBound)
           lTmpLow = lTmpLow + 1
     Loop
 
     Do While (vTempVal < vArray(lTmpHi) And lTmpHi >LowBound)
           lTmpHi = lTmpHi - 1
     Loop
 
     If (lTmpLow <= lTmpHi) Then
         vTmpHold = vArray(lTmpLow)
         vArray(lTmpLow) = vArray(lTmpHi)
         vArray(lTmpHi) = vTmpHold
         lTmpLow = lTmpLow + 1
         lTmpHi = lTmpHi - 1
     End If
 
  Loop
 
  If (LowBound < lTmpHi)   Then QuickSort vArray, LowBound, lTmpHi
  If (lTmpLow < HighBound) Then QuickSort vArray, lTmpLow, HighBound
 
End Function
 
 
Function Canonize(strValue)
'Description: Strips URL strings from the given string
 
  If Len(strValue) = 0 or isNull(strValue) Then Exit Function
 
  strResult = Replace(strValue, "+", " ")
 
  intStart = 1
 
  Do While (InStr(intStart, strResult, "%"))
    intPos = InStr(intStart, strResult, "%")
    Char1 = Mid(strResult, intPos + 1, 1)
    Char2 = Mid(strResult, intPos + 2, 1)
 
    intValue = 16 * HexToDec(Char1)
    intValue = intValue + HexToDec(Char2)
 
    strResult = Replace(strResult, CSTR("%" & Char1 & Char2), chr(intValue))
 
    intStart = intPos + 1
  Loop
 
  Canonize = strResult
 
End Function
 
 
Function HexToDec(strChar)
'Description: Take a guess..
 
  If isNumeric(strChar) Then
    intResult = Int(strChar)
  Else
    uChar = UCase(strChar)
    Select Case uChar
      Case "A"
        intResult = 10
      Case "B"
        intResult = 11
      Case "C"
        intResult = 12
      Case "D"
        intResult = 13
      Case "E"
        intResult = 14
      Case "F"
        intResult = 15
    End Select
  End If
 
  HexToDec = intResult
 
End Function
 
'Response page
%>
<html>
 
<head>
<title>Submission successful!</title>
<meta http-equiv="refresh" content="0;url=<%=strRedirectTo%>">
</head>
 
<body>
Thank you for your submission.
<br>
If you are not redirected automatically, please click <a href="<%=strRedirectTo%>">here</a>.
</body>
 
</html>

Open in new window

0
Nealroy
Asked:
Nealroy
1 Solution
 
peakpeakCommented:
Script code examples to build from here:
http://www.outlookcode.com (download Sues code examples)
http://www.slovaktech.com/code_samples.htm
0

Featured Post

Prep for the ITIL® Foundation Certification Exam

December’s Course of the Month is now available! Enroll to learn ITIL® Foundation best practices for delivering IT services effectively and efficiently.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now