<% 're-define statusPrint in your ASP page to change the presentation of this informaton. function statusPrint(aStr) aStr = replace(server.htmlencode(aStr),chr(13),"
") if left(aStr,1)="*" then response.write"
"&mid(aStr,2)&"" else response.write "
" & aStr end if response.flush end function Function IsValidEmailAddr(anEmailAddr) Dim ary,sUser,sDomain,sIP,oTCP,str, DNSMX, localIP localIP="192.168.0.7" on error resume next IsValidEmailAddr=false if instr(anEmailAddr,"@") < 1 or len(anEmailAddr)<6 then err.raise 1, "CheckEmailAddr("&anEmailAddr&")", "not an email address." exit function end if ary=split( anEmailAddr, "@" ) sUser = ary(0) sDomain = ary(1) if instr(sDomain,".") < 1 then err.raise 1, "CheckEmailAddr("&anEmailAddr&")", "not a valid domain: " & sDomain exit function end if Set DNSMX = Server.CreateObject("ASPMX.Resolver") if err=0 then DNSMX.DNSServer = localIP DNSMX.TimeOutValue = 30 str = lcase(request.servervariables("HTTP_HOST")) ary = split(".."&str,".") str = ary(ubound(ary)-1)&"."&ary(ubound(ary)) DNSMX.Sender = "postmaster@"&str debug "Looking for '"&anEmailAddr&"' from DNS server at:"&replace(DNSMX.DNSServer,locaIP,"local server")&": as '"&DNSMX.Sender&"' via "&DNSMX.Version&" timeout:"&DNSMX.TimeOutValue&"seconds" str = DNSMX.ValidateEMail(anEmailAddr) If Len(str) = 0 Then ' If the response is of zero length, it is valid IsValidEmailAddr=True end if str=DNSMX.ViewConversation() for each str in split(str,vbCrLf) str = split(str," : ",2)(1) statusPrint str if left(str,3)="220" then debug "Server:"&mid(str,4) if left(str,5)="250 R" then debug "Result:"&mid(str,4) next statusPrint "" ' exit function ' statusPrint str if err=0 then exit function else statusprint "400 cant create resolver" end if 'ok, that didn't work, lets try it for ourselves sIP = DNSMX_Domain( sDomain ) ' sIP = "192.168.0.5" if sIP = Empty then statusprint "500 domain not found" err.raise 1, "CheckEmailAddr("&anEmailAddr&")", "domain not found: " & Err.Description exit function end if statusPrint "Opening connection to mail server for "&sDomain&" at "&sIP& " to validate email address "&anEmailAddr TCPOpen_Dom_Port oTCP, sIP, 25 if Err<>0 then err.raise 7, "CheckEmailAddr("&anEmailAddr&")", "Server busy" exit function end if statusPrint "HELO massmind" str = TCPGet(oTCP, "helo massmind" & Chr(13) & Chr(10)) if Err<>0 then err.raise 7, "CheckEmailAddr("&anEmailAddr&")", "Server busy" exit function end if statusPrint str if instr(str,"250") < 1 then err.raise 2, "CheckEmailAddr("&anEmailAddr&")", "After 'HELO' Mailserver says: "&str&"
"&Err.Description exit function end if statusPrint "mail from: " str = TCPGet(oTCP, "mail from: " & Chr(13) & Chr(10)) statusPrint str if instr(str,"250 ") < 1 then if err <> 0 then exit function err.raise 3, "CheckEmailAddr("&anEmailAddr&")", "After 'MAIL FROM:' Mailserver says: "&str exit function end if statusPrint "RCPT TO:<"&anEmailAddr&">" str = TCPGet(oTCP, "rcpt to: <"&anEmailAddr&">" & Chr(13) & Chr(10)) statusPrint str if instr(str,"250 ") < 1 then err.raise 3, "CheckEmailAddr("&anEmailAddr&")", "After 'RCPT TO:' Mailserver says: "&str exit function end if ' statusPrint "QUIT" str = TCPSend(oTCP, "QUIT") ' statusPrint str TCPClose(oTCP) IsValidEmailAddr=True end Function function TCPOpen_Dom_Port(byref aTCP, anIP, aPort) DIM tcp,bOk,str,sRetVal, l, i on error resume next debug "TCPOpen_Dom_Port "&anIP&":"&aPort&"" TCPOpen_Dom_Port = false Set tcp = Server.CreateObject("VBWinsock.TCPIP") if err<>0 then statusprint "500 Can't create Socket" err.raise 1,"TCPOpen_Dom_Port([object], "&anIP&", "&aPort&")"&err.ErrorDescription 'http://www.dimac.net/support/Forum/topic.asp?TOPIC_ID=749 exit function end if tcp.LocalHostIP = request.servervariables("LOCAL_ADDR") tcp.RemoteHostIP = anIP ' tcp.RemoteHostIP = "192.168.0.5" 'test tcp.RemotePort = aPort ' tcp.RemotePort = 80 if err.Number = 0 then bOk = tcp.OpenConnection if err.number=0 then Set aTCP = tcp TCPOpen_Dom_Port = true else err.raise 2,"TCPOpen_Dom_Port([object], "&anIP&", "&aPort&")"&tcp.ErrorDescription on error goto 0 end if end if if IsObject(aTCP) then debug "returning a valid object" else debug "not returning an object" debug "code:"&err.number ' debug "desc:"&tcp.errordescription end if sRetVal = Empty str = Empty c = 0 l = 1 bOk=True while bOk and l > 0 and c < 100 and tcp.IsDataAvailable ' and tcp.ErrorCode=0 bOk = tcp.ReceiveData(str, l) c = c + 1 debug "- mxsmtp.inc TCP.Open_DOM_POrt clearing"&c&": "&str wend end Function function TCPSend(byref aTCP, aRequest) DIM bOk,sRetVal,str,l ' on error resume next debug "TCPSend '"&aRequest&"'" if not IsObject(aTCP) then err.Raise 1,"TCPSend([object],"&server.htmlencode(aRequest)&")","not a valid object" return end if 'clear any data pending from the other end l = 1 bOk = true while bOk and atcp.IsDataAvailable' and l > 0' and atcp.ErrorCode=0 bOk = atcp.ReceiveData(str, l) debug "- Clearing '"&str&"'" wend debug "- Sending '"&aRequest&"' bOk="&bOk if InDebugMode then response.write "" end if bOk = atcp.SendData(aRequest) ' bOk = atcp.SendData("GET /INDEX.HTM" & Chr(13) & Chr(10)) If NOT bOk Then err.Raise 2,"TCPSend([object],"&server.htmlencode(aRequest)&")",aTCP.ErrorDescription exit function end if TCPSend = bOk end Function function TCPGet(byref aTCP, aRequest) DIM bOk,sRetVal,str,l ' on error resume next bOk = TCPSend(aTCP, aRequest) 'Only one call to RecvData might not 'be enough to retrieve all the page. sRetVal = Empty str = Empty debug "- Waiting "&atcp.IsDataAvailable if bOk then bOk = atcp.ReceiveData(sRetVal, l) debug "- Receiving "&atcp.IsDataAvailable while bOk AND atcp.IsDataAvailable ' and atcp.ErrorCode=0' and l > 0' bOk = atcp.ReceiveData(str, l) sRetVal = sRetVal & str debug " '"&str&"'" wend If NOT bOk Then err.Raise 3,"TCPGet([object],"&server.htmlencode(aRequest)&")",atcp.ErrorDescription exit function end if debug "- Returned "&len(sRetVal)&" bytes" if InDebugMode then for y = 1 to len(sRetVal) print right(hex(ascb(mid(sRetVal,y,1))),2) next end if TCPGet = sRetVal end Function function TCPClose(aTCP) ' on error resume next debug "TCPClose" if not IsObject(aTCP) then err.Raise 1,"TCPGet([object],"&aRequest&")","not a valid object" exit function end if atcp.ShutdownConnection Set atcp = Nothing end Function Function DNS_Domain(aDomain) Dim obj on error resume next set obj = CreateObject( "ASPDNS.DNSLookup" ) if err<>0 then debug "Can't create object:ASPDNS.DNSLookup" DNS_Domain = obj.GetIPFromName( cstr(aDomain) ) set obj = nothing if DNS_Domain = empty then set obj = CreateObject( "a1asp.dns" ) if err<>0 then debug "Can't create object:a1asp.dns" DNS_Domain = obj.DNSLookup( cstr(aDomain) ) set obj = nothing end if if DNS_Domain = empty then select case lcase(aDomain) case "hilton.com" case "calc.intershipper.net" DNS_Domain = "216.58.34.10" case "mail.efplus.com","efplus.com" DNS_Domain = localIP end select end if end Function function skipname(aStr, byRef aPtr) DIM p, l, i 'InDebugMode=true skipname = "" i = 10 l = 1 p = aPtr while i > 0 and l > 0 and aPtr <= len(aStr) and p > 0 and p <=len(aStr) i = i - 1 l = ascb(mid(aStr,p,1)) if aPtr = p then aPtr = aPtr + 1 p = p + 1 debug "past:"&aPtr&" at:"&p&" for:"&l while l >= 192 and p > 0 and p <=len(aStr) p = (l AND &H3F)*256 + ascb(mid(aStr, p, 1)) + 4 l = ascb(mid(aStr,p-1,1)) wend skipname = skipname&"."&mid(aStr, p, l) if aPtr = p then aPtr = aPtr + l p = p + l wend aPtr = aPtr + 1 debug "name:"&skipname&"." end function DIM sDNSMXIP Function DNSMX_Domain(sDomain) Dim obj,str,q,x,y,MX,tcp,name,term,ip,DNSMX Dim MXPreference, MXServer, MXTopPreference 'on error resume next CONST TYPE_MX =15 if sDNSMXIP = Empty then sDNSMXIP="127.0.0.1" statusPrint "Looking up MX server for "&sDomain else statusPrint "Looking up MX server for "&sDomain&" using DNS server at "&sDNSMXIP end if 'fixed answers for known cases select case lcase(sDomain) case "hilton.com" DNSMX_Domain = "192.251.125.161" case "efplus.com","piclist.com","sxlist.com","piclist.org","massmind.org" DNSMX_Domain = "127.0.0.1" case else 'try the tool from www.internext.co.za/stefan/aspmx/ Set DNSMX = Server.CreateObject("ASPMX.Resolver") if Err = 0 then DNSMX.DNSServer = localIP DNSMX.Domain = sDomain DNSMX.TimeOutValue = 10 debug "Looking for "&DNSMX.Domain&" on "&DNSMX.DNSServer&" via "&DNSMX.Version&" timeout:"&DNSMX.TimeOutValue str = DNSMX.Resolve() ' Attempt resolving the MX record(s) If Len(str) > 0 Then debug "Error : " & str Else debug " - " & DNSMX.MXCount & " records :" q=0:name="" For x = 1 To DNSMX.MXCount debug " - "& x & ":" & DNSMX.MX(x) & ": Priority:" & DNSMX.MXPriority(x) & "." if DNSMX.MXPriority(x) > q then q = DNSMX.MXPriority(x):name=DNSMX.MX(x) Next End If ip = DNS_Domain(name) debug " - using:"&name&":"&ip DNSMX_Domain = ip end if 'ok, nothing else is working... try doing it ourselves... if DNSMX_Domain = Empty then str = Empty randomize str = chr(0)&chr(rnd()*255)&chr(1)&chr(0)&chr(0)&chr(1) str = str&chr(0)&chr(0)&chr(0)&chr(0)&chr(0)&chr(0) for each term in split(sDomain,".") str = str & chr(len(term))&term next str = str&chr(0) str = str&chr(0)&chr(TYPE_MX)&chr(0)&chr(255) str = chr(0)&chr(len(str))&str TCPOpen_Dom_Port tcp, sDNSMXIP, 53 str = TCPGet(tcp, str)&chr(0) x = 15 if len(str) > 14 then if ascb(mid(str,9,1))*256 + ascb(mid(str,10,1)) < 1 then x = len(str) err.raise 1, "DNSMX_Domain("&sDomain&")","There is NO mail server (MX) record for "&sDomain exit function end if MX = "" MXTopPreference = 999 q = ascb(mid(str,7,1))*256 + ascb(mid(str,8,1)) while x < len(str) name = skipname(str, x ) if q > 0 then debug "Question #"&q q = q -1 x = x + 3 else y = ascb(mid(str,x,1))*256 + ascb(mid(str,x+1,1)) x = x + 8 debug "TYPE:"&y select case y case 0 x = len(str) case 1 ip=ascb(mid(str,x+2,1))&"."&ascb(mid(str,x+3,1))&"."&ascb(mid(str,x+4,1))&"."&ascb(mid(str,x+5,1)) MX=replace(MX,name&":",name&":"&ip&":") debug MX case 15 y = x+4 MXServer = skipname(str,y) MXPreference = ascb(mid(str,x+2))*256+ascb(mid(str,x+3)) If MXPreference < MXTopPreference then MX="|"&MXPreference&","&MXServer&":"&MX MXTopPreference=MXPreference else MX=MX&"|"&MXPreference&","&MXServer&":" end if debug MX end select debug "AT:"&x&"="&ascb(mid(str,x,1))&" AT:"&x+1&"="&ascb(mid(str,x+1,1)) y = ascb(mid(str,x,1))*256 + ascb(mid(str,x+1,1)) debug "RDATALEN:"&y x = x + y + 2 debug "AT:"&x end if wend end if TCPClose(tcp) statusPrint "Response: "&len(str)&" bytes "&replace(replace(MX,"|",strCrLf), ":"," :") if ascb(mid(str,13,1))*256 + ascb(mid(str,14,1)) < 1 then x = len(str) err.raise 2, "DNSMX_Domain("&sDomain&")","Mail server name(s) found, but the name(s) doesn't resolve to an IP Address" exit function end if DNSMX_Domain=split(MX,":")(1) end if end select debug "found IP address:"&DNSMX_Domain end Function %>