how to retrieve a json from header [duplicate] - asp-classic

This question already has answers here:
Accessing a request's body using classic ASP?
(3 answers)
Closed 3 years ago.
am using Request.ServerVariables to get webhook response from GoCardless in classic asp which is calling a page on my server http:/www.example.com/webhook.asp
My code in webhook.asp:
For Each var in Request.ServerVariables
WriteLog var & " = " & Request.ServerVariables(var) , "gocardless"
Next
the output is ok, i can read
Content-Length: 353
Content-Type: application/json
Accept: */*
Accept-Encoding: gzip;q=1.0,deflate;q=0.6,identity;q=0.3
Host: admin.controle-reglementaire.fr
User-Agent: gocardless-webhook-service/1.1
Origin: https://api.gocardless.com
Webhook-Signature: 71ef0f915569e082f090f5150fdf4144be4fed242b1253ad620544c4dd8d615a
my code works fine but am not able to retrive the json coming with
i must get the full response information as shown in Gocardless Guide
Originhttps://api.gocardless.com
User-Agentgocardless-webhook-service/1.1
Content-Typeapplication/json
Webhook-Signature71ef0f915569e082f090f5150fdf4144be4fed242b1253ad620544c4dd8d615a
Corps
{
"events": [
{
"id": "EVTESTC4TEBZP2",
"created_at": "2019-12-21T10:18:30.168Z",
"resource_type": "payments",
"action": "failed",
"links": {
"payment": "index_ID_123"
},
"details": {
"origin": "bank",
"cause": "insufficient_funds",
"scheme": "sepa_core",
"reason_code": "AM04",
"description": "The customer's account had insufficient funds to make this payment."
},
"metadata": {}
}
]
}
what code should i add to get the json response located in the header
thx

well after more than 48 hours of google search this fixed my problem
Dim lngBytesCount, bstring
If Request.TotalBytes > 0 Then
lngBytesCount = Request.TotalBytes
bstring= BytesToStr(Request.BinaryRead(lngBytesCount))
response.Clear
WriteLog bstring , "gocardless"
end if
Function BytesToStr(bytes)
Dim Stream
Set Stream = Server.CreateObject("Adodb.Stream")
Stream.Type = 1 'adTypeBinary
Stream.Open
Stream.Write bytes
Stream.Position = 0
Stream.Type = 2 'adTypeText
Stream.Charset = "UTF-8"
BytesToStr = Stream.ReadText
try = BytesToStr
Stream.Close
Set Stream = Nothing
End Function

ok guys thanks all for your hel but this is the complete solution that helped solving my problem and it works great
<!-- #include file="aspJSON1.17.asp"-->
<%
dim filename : filename = Request.ServerVariables("HTTP_Webhook-Signature")
'response.write "filename = " & filename
'---------------------------------------------------------------------------------------------------
Dim lngBytesCount, bstring
If Request.TotalBytes > 0 Then
lngBytesCount = Request.TotalBytes
response.ContentType = "application/json;charset=UTF-8"
bstring= BytesToStr(Request.BinaryRead(lngBytesCount))
'response.Clear
end if
'response.write bstring
'---------------------------------------------------------------------------------------------------
WriteLog bstring , filename
'---------------------------------------------------------------------------------------------------
Set oJSON = New aspJSON
oJSON.loadJSON bstring
For Each record In oJSON.data("events")
Set this = oJSON.data("events").item(record)
Response.Write "<p>" & this.item("id") '& " | " & this.item("charge_date") & " | " & this.item("amount") & " | " & this.item("description") & " | " & this.item("status") & " | " & this.item("links")("mandate") & " | " & this.item("links")("subscription") & "<p>"
Next
Set oJSON = Nothing
'---------------------------------------------------------------------------------------------------
Function BytesToStr(bytes)
Dim Stream
Set Stream = Server.CreateObject("Adodb.Stream")
Stream.Type = 1 'adTypeBinary
Stream.Open
Stream.Write bytes
Stream.Position = 0
Stream.Type = 2 'adTypeText
Stream.Charset = "UTF-8"
BytesToStr = Stream.ReadText
try = BytesToStr
Stream.Close
Set Stream = Nothing
End Function
'---------------------------------------------------------------------------------------------------
sub WriteLog(LogInfo, FileName)
dim FSO, Inf, dir, Fnm
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
dir = "D:\webserver\experthost\trace"
Fnm = dir & "\" & FileName & ".json"
' Ouverture du fichier
' Fnm : nom du fichier
' 8 : mode append
' true : le fichier est crée s'il n'existe pas
set inF = FSO.OpenTextFile(Fnm,2,true)
'*******************************************
inF.writeLine LogInfo
inF.close
set inF = nothing
end sub
%>

Related

Keep Getting an "object required" Error. Tried troubleshooting for a while to no avail.

I keep receiving an object required error on line 32 for "oFileCollection" and am unsure if the cause of the problem is the function not receiving the information from the Case or if the function needs to have the whole argument and code inside of it in order to retrieve the information.
Option Explicit
Dim sDirectoryPath,Search_Days,iDaysOld,CmdArg_Object,lastModDate
Dim oFSO,oFolder,oFileCollection,oFile,oTF, SubFolder
'------------------------------------------------------
Set CmdArg_Object = Wscript.Arguments
Select Case (CmdArg_Object.Count)
Case 2
sDirectoryPath = CmdArg_Object.item(0)
Search_Days = CmdArg_Object.item(1)
Case Else
WScript.Echo "SearchFiles.vbs requires 2 parameters:" &_
vbcrlf & "1) Folder Path" &_
vbcrlf & "2) # Days to Search"
WScript.Quit
End Select
Set oFSO = CreateObject("Scripting.FileSystemObject")
iDaysOld=Date+(-1*Search_Days)
Set oTF = oFSO.CreateTextFile("C:\Old Files.txt")
WScript.Echo Now & " - Beginning " & Search_Days & " day search of " & sDirectoryPath
TraverseFolders oFSO.GetFolder(sDirectoryPath)
Set oFolder = oFSO.GetFolder(sDirectoryPath)
Set oFileCollection = oFolder.Files
Function TraverseFolders (FolderName)
Set SubFolder = oFileCollection
For Each SubFolder In FolderName.SubFolders
TraverseFolders (SubFolder)
Next
For Each oFile In SubFolder.Files
lastModDate = oFile.DateLastModified
If (lastModDate <= iDaysOld) Then
oTF.WriteLine (oFile.Path)
oTF.WriteLine (oFile.DateLastModified)
oTF.WriteLine ("-----------------------")
End If
Next
End Function
WScript.Echo "Now - Finished"
Here's my quite old example; posted as is unchanged…
Function ShowFolderListPlus analyzes supplied folder and calls itself recursively for all subfolders.
option explicit
Dim MyFolder, MyAgeLimitInDays, objFSO, numDateDiff, sResult
MyFolder = "C:\testC"
MyAgeLimitInDays = 365
sResult = ""
Set objFSO = CreateObject( "Scripting.FileSystemObject")
ShowFolderListPlus( MyFolder)
WScript.Echo "Testing files older/newer than " & Cstr( MyAgeLimitInDays) _
& " days:" & vbNewLine & sResult
WScript.Quit
Function ShowFolderListPlus( FolderToAnalyse)
Dim objFolder, itemFile, itemFldr, colFileList, colSubFldr, parFolder, sc, sa
sa = String( DepthOfPath( FolderToAnalyse), "-")
sc = FolderToAnalyse & " " & sa & vbNewLine
Set objFolder = objFSO.GetFolder( FolderToAnalyse)
Set colFileList = objFolder.Files
For Each itemFile in colFileList
If StrComp( Right( itemFile.name, 4), ".bat", vbTextCompare) = 0 Then
'exclude files of specified extension'
Else
numDateDiff = DateDiff("d", itemFile.DateCreated, now)
If numDateDiff > MyAgeLimitInDays Then
sc = sc & sa & "old "
'''-------------------------------'''
''' objFSO.DeleteFile( itemFile) ''' delete file older than limit
'''-------------------------------'''
Else
sc = sc & sa & "new "
End If
sc = sc & itemFile.name & " " & numDateDiff & vbNewLine
End If
Next
Set colSubFldr = objFolder.SubFolders
For Each itemFldr in colSubFldr
parFolder = FolderToAnalyse & "\" & itemFldr.name
ShowFolderListPlus( parFolder) 'calls the procedure itself recursively'
Next
sResult = sc & sResult
ShowFolderListPlus = sc
End Function
Function DepthOfPath( strPth)
Dim AuxArray
AuxArray = Split( strPth, "\", -1, vbTextCompare)
DepthOfPath = UBound( AuxArray)
End Function
Output sample:
==> cscript D:\VB_scripts\Oldies\Folders\filescolection_in_subfolders.vbs
Testing files older/newer than 365 days:
C:\testC -
-old bar.txt 777
-old foo.txt 777
C:\testC\NewFolder21 --
--old NewTextFile1 1289
--new NewTextFile2 162
C:\testC\a --
C:\testC\43381802 --
--old MailCliеnt.txt 582
--old q44554519.html 538
C:\testC\43381802\bubu ---
---new 3-3-2018-.png 277
---old NewTextDocument.txt 1146
---old output.txt 1146

send a file and parameter HTTP Post with VBS

I'm new working with HTTP protocol and haven't worked with VBS for some time.
The problem I'm having is sending a parameter and an upload file to a web service.
I just don't understand what some of the code is. Below is part of the code.
With CreateObject("MSXML2.ServerXMLHTTP")
.setOption 2, 13056 'http://msdn.microsoft.com/en-
us/library/ms763811(v=VS.85).aspx
.SetTimeouts 0, 60000, 300000, 300000
.Open "POST",
"https://192.168.100.100/api/import_file_here.json", False
.SetRequestHeader "Content-type", "multipart/form-data; boundary=" &
strBoundary 'THIS SEND THE FILE
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" '
THIS SEND THE PARAMETER.
.Send bytPD ' sends param
.Send bytPayLoad '''SEND FILE
I know I can't use .Send twice. I believe I need to make a change in the below code block.
With CreateObject("ADODB.Stream")
.Mode = 3
.Charset = "Windows-1252"
.Open
.Type = 2
.WriteText "--" & strBoundary & vbCrLf
'.WriteText "Content-Disposition: form-data; name=""file""; filename=""" &
strFile & """" & vbCrLf
.WriteText "Content-Disposition: form-data; name=""file"";
publication=""moveit_test_pub"""
'.WriteText "Content-Type: """ & strContentType & """" & vbCrLf & vbCrLf
.Position = 0
.Type = 1
.Write bytData
.Position = 0
.Type = 2
.Position = .Size
.WriteText vbCrLf & "--" & strBoundary & "--"
.Position = 0
.Type = 1
bytPayLoad = .Read
bytPD = "publication=moveit_test_pub"
bytPD = "publication=moveit_test_pub" is the parameter I need along with the file upload. I'm just not sure how to add it to the above block. If that's where I'm supposed to change. I'm posting the entire code below for reference.
Thanks for all your help!
strFilePath = "C:\SCAudience_TEST5.txt"
UploadFile strFilePath, strUplStatus, strUplResponse
MsgBox strUplStatus & vbCrLf & strUplResponse
Sub UploadFile(strPath, strStatus, strResponse)
Dim strFile, strExt, strContentType, strBoundary, bytPD, bytData,
bytPayLoad
On Error Resume Next
With CreateObject("Scripting.FileSystemObject")
If .FileExists(strPath) Then
strFile = .GetFileName(strPath)
strExt = .GetExtensionName(strPath)
Else
strStatus = "File not found"
Exit Sub
End IF
End With
With CreateObject("Scripting.Dictionary")
.Add "txt", "text/plain"
.Add "html", "text/html"
.Add "php", "application/x-php"
.Add "js", "application/x-javascript"
.Add "vbs", "application/x-vbs"
.Add "bat", "application/x-bat"
.Add "jpeg", "image/jpeg"
.Add "jpg", "image/jpeg"
.Add "png", "image/png"
.Add "exe", "application/exe"
.Add "doc", "application/msword"
.Add "docx", "application/vnd.openxmlformats-
officedocument.wordprocessingml.document"
.Add "xls", "application/vnd.ms-excel"
.Add "xlsx", "application/vnd.openxmlformats-
officedocument.spreadsheetml.sheet"
strContentType = .Item(LCase(strExt))
End With
If strContentType = "" Then
strStatus = "Invalid file type"
Exit Sub
End If
With CreateObject("ADODB.Stream")
.Type = 1
.Mode = 3
.Open
.LoadFromFile strPath
If Err.Number <> 0 Then
strStatus = Err.Description & " (" & Err.Number & ")"
Exit Sub
End If
bytData = .Read
bytPD = "publication=moveit_test_pub"
End With
strBoundary = String(6, "-") & Replace(Mid(CreateObject("Scriptlet.TypeLib").Guid, 2, 36), "-", "")
With CreateObject("ADODB.Stream")
.Mode = 3
.Charset = "Windows-1252"
.Open
.Type = 2
.WriteText "--" & strBoundary & vbCrLf
' .WriteText "Content-Disposition: form-data; name=""file""; filename=""" & strFile & """" & vbCrLf
.WriteText "Content-Disposition: form-data; name=""file""; publication=""moveit_test_pub"""
'.WriteText "Content-Type: """ & strContentType & """" & vbCrLf & vbCrLf
.Position = 0
.Type = 1
.Write bytData
.Position = 0
.Type = 2
.Position = .Size
'' .WriteText vbCrLf & "--" & strBoundary & "--"
.Position = 0
.Type = 1
bytPayLoad = .Read
bytPD = "publication=moveit_test_pub"
End With
With CreateObject("MSXML2.ServerXMLHTTP")
.setOption 2, 13056 'http://msdn.microsoft.com/en-us/library/ms763811(v=VS.85).aspx
.SetTimeouts 0, 60000, 300000, 300000
.Open "POST", "https://192.168.100.100/api/import_file_here.json", False
.SetRequestHeader "Content-type", "multipart/form-data; boundary=" & strBoundary 'THIS SEND THE FILE IF BOTH SELECTED SEND PARM AND TEXT OF FILE
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded" ' THIS SEND THE PARAMETER.
''' .Send bytPD ' sends param
' .SetRequestHeader "Content-type", "multipart/form-data; boundary=" & strBoundary 'NEW LINE
.Send bytPayLoad '''SEND FILE
MsgBox bytPD
If Err.Number <> 0 Then
strStatus = Err.Description & " (" & Err.Number & ")"
Else
strStatus = .StatusText & " (" & .Status & ")"
End If
If .Status = "400" Then strResponse = .ResponseText
If .Status = "401" Then strResponse = .ResponseText
If .Status = "200" Then strResponse = .ResponseText
End With
End Sub
I found a solution. This was my logic:
with curl you can send a file + parameters with:
curl -XPOST '127.0.0.1:8000' -F 'file=#/Users/luca/Desktop/img.png' -F 'id=123456'
In this case you can see:
IP = 127.0.0.1 (localhost)
Port = 8000
Filename = img.png
Parameter = "id" with value 123456
If you use netcat in listening mode like this...
nc -l -p 8000
This means that it's listening for anything on port 8000 of the localhost = 127.0.0.1 (I'm using the Mac version of Netcat. You may need to change some parameters to make it work like this).
So: launch netcat in listening mode, launch the previous curl command and you will see the entire POST packet. Now you know how it is made.
It will look like that:
POST / HTTP/1.1
Host: 127.0.0.1:8000
User-Agent: curl/7.54.0
Accept: */*
Content-Length: 427
Expect: 100-continue
Content-Type: multipart/form-data; boundary=------------------------60cd44468072da0e
--------------------------60cd44468072da0e
Content-Disposition: form-data; name="file"; filename="img.png"
Content-Type: application/octet-stream
?PNG
IHDR
??w&sRGB???gAMA??
?a pHYs??(J?IDAT(Scd``??D&(MU?
?bg?ܞ?IEND?B`?
--------------------------60cd44468072da0e
Content-Disposition: form-data; name="id"
123456
--------------------------60cd44468072da0e--
Now that you know how the working packet is made, you can replicate it.
For the header use:
httpServer.SetRequestHeader "Content-type", "multipart/form-data; boundary=------------------------2deddc24cb2a8ca2;"
(boundary is sort of delimiter. Check it on Google)
Then you can build the body of the POST request:
body = "--" & "------------------------2deddc24cb2a8ca2" & vbCrLf & _
"Content-Disposition: form-data; name=""file""; filename=""" & objFSO.GetFileName(objFile) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
FILE_CONTENT & vbCrLf & _
"--" & "------------------------2deddc24cb2a8ca2" & vbCrLf & _
"Content-Disposition: form-data; name=""id""" & vbCrLf & vbCrLf & _
ID & vbCrLf & _
"--" & "------------------------2deddc24cb2a8ca2" & "--" & vbCrLf & vbCrLf
NOTE:
in the body you can see that every boundary has an additional "--" string at the beginning (infact i wrote "--" & "------------------------2deddc24cb2a8ca2") and an additional "--" at the end of the last boundary.
The header must have ";" at the end of the line in vbs even if is not visible in the previous captured POST request. I don't know exactly why.
The FILE_CONTENT variable in the body is the content of your file
Take care for every vbCrLf (end of the line) or the POST request may not be valid.
PROBLEM:
The code you posted below should open a stream, write the first part of the body as a string, write the BINARY content of your file, write the last part of the body as a string.
Combining String and Binary data it's not working for me: i can send only the binary or only text file. If i convert the binary content to string, the remote server will get a corrupted (different) file...
example (binary file only):
Set stream = CreateObject("ADODB.Stream")
stream.Mode = 3
stream.Type = 1
stream.Open
stream.LoadFromFile("C:\Users\Luca\Desktop\i.png")
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
objHttp.Open "POST", "http://10.0.2.2:8000/", False
objHttp.Send stream.Read(stream.Size)
example (text file only)
Set stream = CreateObject("ADODB.Stream")
stream.Mode = 3
stream.Type = 2
stream.Open
stream.LoadFromFile("C:\Users\Luca\Desktop\i.txt")
readBinaryFile = stream.Read
requestBody = "--------------------------2deddc24cb2a8ca2" & vbCrLf & _
"Content-Disposition: form-data; name=""file""; filename=""" & objFSO.GetFileName(objFile) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
readBinaryFile & vbCrLf & _
"--------------------------2deddc24cb2a8ca2" & vbCrLf & _
"Content-Disposition: form-data; name=""id""" & vbCrLf & vbCrLf & _
ID & vbCrLf & _
"--------------------------2deddc24cb2a8ca2--" & vbCrLf & vbCrLf
As i told you, if you change the stream.Type from 2 to 1 (for Binary) you will end to send a corrupted file.
My solution was to send the parameter as an extra Header value:
Example:
httpServer.Open "POST", "http://10.0.2.2:8000/", False
httpServer.SetRequestHeader "Content-type", "application/octet-stream;"
httpServer.SetRequestHeader "Id", ID
httpServer.Send stream.Read(stream.Size)
Now i can send the parameter (Id) AND the binary file...
NOTE: With Content-type: application/octet-stream you can send unknow file extension too

In Classic ASP reading cXML Files, is it required to point your dtd link to local files?

Unfortunately, we've inherited an old Classic ASP site and are writing new code for a round trip punch-out site. Reading in the cXML file, we're continually erroring out on the 2nd line !DOCTYPE cXML SYSTEM "http://xml.../cXML.dtd.
If we capture the location of the dtd file and change it to a local file, i.e., file:///c:/....dtd it works. Is there no way to get this to work using the http location? I'd rather not store all the dtd file versions locally.
Our Code is:
Dim olddtdvalue
Dim newdtdvalue
Dim xmlfilename
olddtdvalue = "http://xml.cxml.org/schemas/cXML/"
newdtdvalue = "file:///d:/Websites/FSIResponsive/cXML/"
xmlfilename ="PORS_" & formatdatetime(now,vblongdate) & " " & replace(formatdatetime(now,vblongtime),":","_") & ".xml"
set fs=Server.CreateObject("Scripting.FileSystemObject")
set f=fs.CreateTextFile("d:\WebSites\FSIResponsive\cXML\InFiles\" & xmlfilename,true)
f.write("remote host: " & request.ServerVariables("REMOTE_HOST") & vbcrlf & vbcrlf)
totalBytes = Request.TotalBytes
If totalBytes > 0 Then
xml = Request.BinaryRead( totalBytes )
for i = 1 to totalBytes
xmlstr = xmlstr + String(1,AscB(MidB(xml, i, 1)))
Next
f.write(xmlstr)
xml2 = xmlstr
xml2 = Replace(xml2,olddtdvalue,newdtdvalue)
End if
Set xdoc = Server.CreateObject("Microsoft.XMLDOM")
' Set xdoc = Server.CreateObject("MSXML2.DOMDocument.6.0")
xdoc.ValidateOnParse = True
xdoc.async = False
xdoc.resolveExternals = True
' response.write xml2
loadStatus = xdoc.loadXML(xml2)
As you can see, we've tried using MSXML2.DOMDocument.6.0, but that doesn't work either.
Thanks,
Alan
Update:
Here's the code I finally got working:
Dim xmlfilename
Dim URL
totalBytes = Request.TotalBytes
If totalBytes > 0 Then
xml = Request.BinaryRead( totalBytes )
for i = 1 to totalBytes
xmlstr = xmlstr + String(1,AscB(MidB(xml, i, 1)))
Next
xml2 = xmlstr
End if
Set xdoc = Server.CreateObject("MSXML2.DOMDocument.6.0")
xdoc.setProperty "ServerHTTPRequest", True
xdoc.setProperty "ProhibitDTD",False
xdoc.resolveExternals = True
xdoc.ValidateOnParse = True
xdoc.async = False
loadStatus = xdoc.LoadXML(xml2)
Alan

Classic ASP internal error on contact form

My form takes me to an internal error page upon submission. I have all the fields defined, and my SMTP info passing through. It looks as if everything should work. But it simply doesn't.
Any suggestions is appreciated.
<%
'Declaring Variables
Dim smtpserver,youremail,yourpassword,ContactUs_Name,ContactUs_Email
Dim ContactUs_Subject,ContactUs_Body,Action,IsError
' Edit these 3 values accordingly
smtpserver = "mysmtperserver"
youremail = "myemail"
yourpassword = "mypassword"
' Grabbing variables from the form post
ContactUs_Name = Server.HTMLEncode(Request("ContactUs_Name"))
ContactUs_Email = Server.HTMLEncode(Request("ContactUs_Email"))
ContactUs_Subject = Server.HTMLEncode(Request("ContactUs_Subject"))
ContactUs_Body = Server.HTMLEncode(Request("ContactUs_Body"))
ContactUs_Captcha = Request("recaptcha_response_field")
Action = Request("Action")
' Used to check that the email entered is in a valid format
Function IsValidEmail(Email)
Dim ValidFlag,BadFlag,atCount,atLoop,SpecialFlag,UserName,DomainName,atChr,tAry1
ValidFlag = False
If (Email <> "") And (InStr(1, Email, "#") > 0) And (InStr(1, Email, ".") > 0) Then
atCount = 0
SpecialFlag = False
For atLoop = 1 To Len(Email)
atChr = Mid(Email, atLoop, 1)
If atChr = "#" Then atCount = atCount + 1
If (atChr >= Chr(32)) And (atChr <= Chr(44)) Then SpecialFlag = True
If (atChr = Chr(47)) Or (atChr = Chr(96)) Or (atChr >= Chr(123)) Then SpecialFlag = True
If (atChr >= Chr(58)) And (atChr <= Chr(63)) Then SpecialFlag = True
If (atChr >= Chr(91)) And (atChr <= Chr(94)) Then SpecialFlag = True
Next
If (atCount = 1) And (SpecialFlag = False) Then
BadFlag = False
tAry1 = Split(Email, "#")
UserName = tAry1(0)
DomainName = tAry1(1)
If (UserName = "") Or (DomainName = "") Then BadFlag = True
If Mid(DomainName, 1, 1) = "." then BadFlag = True
If Mid(DomainName, Len(DomainName), 1) = "." then BadFlag = True
ValidFlag = True
End If
End If
If BadFlag = True Then ValidFlag = False
IsValidEmail = ValidFlag
End Function
%>
<%
If Action = "SendEmail" Then
' Here we quickly check/validate the information entered
' These checks could easily be improved to look for more things
If IsValidEmail(ContactUs_Email) = "False" Then
IsError = "Yes"
Response.Write("<font color=""red"">Please enter valid Email address.</font><br>")
End If
If ContactUs_Name = "" Then
IsError = "Yes"
Response.Write("<font color=""red"">Please enter your Name.</font><br>")
End If
If ContactUs_Subject = "" Then
IsError = "Yes"
Response.Write("<font color=""red"">Please enter a Subject.</font><br>")
End If
If ContactUs_Body = "" Then
IsError = "Yes"
Response.Write("<font color=""red"">Please include Message.</font><br>")
End If
if ContactUs_Captcha = "" Then
IsError = "Yes"
Response.Write("<font color=""red"">Captcha Required.</font><br>")
End If
End If
' If there were no input errors and the action of the form is "SendEMail" we send the email off
If Action = "SendEmail" And IsError <> "Yes" Then
Dim strBody
' Here we create a nice looking html body for the email
strBody = strBody & "<font face=""Arial"">Contact Us Form submitted at " & Now() & vbCrLf & "<br><br>"
strBody = strBody & "From http://" & Request.ServerVariables("HTTP_HOST") & vbCrLf & "<br>"
strBody = strBody & "IP " & Request.ServerVariables("REMOTE_ADDR") & vbCrLf & "<br>"
strBody = strBody & "Name" & " : " & " " & Replace(ContactUs_Name,vbCr,"<br>") & "<br>"
strBody = strBody & "Email" & " : " & " " & Replace(ContactUs_Email,vbCr,"<br>") & "<br>"
strBody = strBody & "Subject" & " : " & " " & Replace(ContactUs_Subject,vbCr,"<br>") & "<br>"
strBody = strBody & "<br>" & Replace(ContactUs_Body,vbCr,"<br>") & "<br>"
strBody = strBody & "</font>"
Dim ObjSendMail
Set ObjSendMail = CreateObject("CDO.Message")
'This section provides the configuration information for the remote SMTP server.
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'Send the message using the network (SMTP over the network).
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpserver
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False 'Use SSL for the connection (True or False)
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'basic (clear-text) authentication
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = youremail
ObjSendMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = yourpassword
ObjSendMail.Configuration.Fields.Update
'End remote SMTP server configuration section==
ObjSendMail.To = youremail
ObjSendMail.Subject = ContactUs_Subject
ObjSendMail.From = ContactUs_Email
' we are sending a html email.. simply switch the comments around to send a text email instead
ObjSendMail.HTMLBody = strBody
'ObjSendMail.TextBody = strBody
ObjSendMail.Send
Set ObjSendMail = Nothing
' change the success messages below to say or do whatever you like
' you could do a response.redirect or offer a hyperlink somewhere.. etc etc
%>
If you can't do much with custom error pages then you can use "On Error Resume Next" to trap errors, something like:
On Error Resume Next
'Put your code in here
'Write out error messages
If err.number > 0 then
response.write "Error: err.description & " on line number <strong>" & err.line & "</strong>"
END IF
On Error Goto 0
Caveat: I'd just recommend taking this out once you've got your code working as can mask issues if not used carefully. Instead look at getting some proper error handling and logging in place using custom error pages.
Just at a quick glance... this section looks to be missing an END IF
If (atCount = 1) And (SpecialFlag = False) Then
BadFlag = False
tAry1 = Split(Email, "#")
UserName = tAry1(0)
DomainName = tAry1(1)

What is a fast and efficient way to import images by URL?

Would I just use MSXML and import as binary? Or is there another more efficient way?
There are gigs and gigs of JPEGs to fetch.
I have written something in the past, the code below will save remote image on the server disk. It's classic ASP and pretty efficient:
<%
Const CONTENT_FOLDER_NAME = "StoredContents"
Dim strImageUrl
strImageUrl = "http://www.gravatar.com/avatar/8c488f9c3d3da5bb756507179a3d53fd?s=32&d=identicon&r=PG"
Call SaveOnServer(strImageUrl, "bill_avatar.jpg")
Sub SaveOnServer(url, strFileName)
Dim strRawData, objFSO, objFile
Dim strFilePath, strFolderPath, strError
strRawData = GetBinarySource(url, strError)
If Len(strError)>0 Then
Response.Write("<span style=""color: red;"">Failed to get binary source. Error:<br />" & strError & "</span>")
Else
strFolderPath = Server.MapPath(CONTENT_FOLDER_NAME)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FolderExists(strFolderPath)) Then
objFSO.CreateFolder(strFolderPath)
End If
If Len(strFileName)=0 Then
strFileName = GetCleanName(url)
End If
strFilePath = Server.MapPath(CONTENT_FOLDER_NAME & "/" & strFileName)
Set objFile = objFSO.CreateTextFile(strFilePath)
objFile.Write(RSBinaryToString(strRawData))
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Response.Write("<h3>Stored contents of " & url & ", total of <span style=""color: blue;"">" & LenB(strRawData) & "</span> bytes</h3>")
Response.Write("<a href=""" & CONTENT_FOLDER_NAME & "/" & strFileName & """ target=""_blank""><span style=""color: blue;"">" &_
strFileName & "</span></a>")
End If
End Sub
Function RSBinaryToString(xBinary)
''# Antonin Foller, http://www.motobit.com
''# RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
''# to a string (BSTR) using ADO recordset
Dim Binary
'' #MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
If LBinary>0 Then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
RSBinaryToString = RS("mBinary")
Else
RSBinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
''# © 2000 Antonin Foller, http://www.motobit.com
''# MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
''# Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Function GetBinarySource(url, ByRef strError)
Dim objXML
Set objXML=Server.CreateObject("Microsoft.XMLHTTP")
GetBinarySource=""
strError = ""
On Error Resume Next
objXML.Open "GET", url, False
objXML.Send
If Err.Number<>0 Then
Err.Clear
Set objXML = Server.CreateObject("MSXML2.ServerXMLHTTP")
objXML.Open "GET", url, False
objXML.Send
If Err.Number<>0 Then
strError = "Error " & Err.Number & ": " & Err.Description
Err.Clear
Exit Function
End If
End If
On Error Goto 0
GetBinarySource=objXML.ResponseBody
Set objXML=Nothing
End Function
Function GetCleanName(s)
Dim result, x, c
Dim arrTemp
arrTemp = Split(s, "/")
If UBound(arrTemp)>0 Then
For x=0 To UBound(arrTemp)-1
result = result & GetCleanName(arrTemp(x)) & "_"
Next
result = result & GetPageName(s)
Else
For x=1 To Len(s)
c = Mid(s, x, 1)
If IsValidChar(c) Then
result = result & c
Else
result = result & "_"
End If
Next
End If
Erase arrTemp
GetCleanName = result
End Function
Function IsValidChar(c)
IsValidChar = (c >= "a" And c <= "z") Or (c >= "A" And c <= "Z") Or (IsNumeric(c))
End Function
Function GetPageName(strUrl)
If Len(strUrl)>0 Then
GetPageName=Mid(strUrl, InStrRev(strUrl, "/")+1, Len(strUrl))
Else
GetPageName=""
End If
End Function
%>
Just call SaveOnServer sub routine passing the URL and desired file name, you can also omit the file name and in that case, the file name will be taken from the URL itself.
The server folder is defined as constant and will be in the same place as .asp file.
Here is the gist of how to download and save files in script:-
Function DownloadAndSave(sourceUrl, destinationFile)
Dim req : Set req = CreateObject("WinHttp.WinHttpRequest.5.1")
req.Open "GET", sourceUrl, false
req.Send
Dim stream : Set stream = CreateObject("ADODB.Stream")
stream.Type = 1 ''# adTypeBinary
stream.Open
stream.Write req.ResponseBody
stream.SaveToFile destinationFile, 2
stream.Close
End Function

Resources