用ASP实现支持附件的EMail系统(2)

     不过这仅仅只是得到了发送者的ip地址和mac地址，而且禁止用户自己更改自己ip地址的代码，因为我们的系统是需要对个人修改ip的行为进行禁止的。
  
  ＜%
  strIP = Request.ServerVariables("REMOTE_ADDR")
  
  
  Set net = Server.CreateObject("wscript.network")
  Set sh = Server.CreateObject("wscript.shell")
  sh.run "%comspec% /c nbtstat -A " & strIP & " ＞ c:\" & strIP & ".txt",0,true
  Set sh = nothing
  Set fso = createobject("scripting.filesystemobject")
  Set ts = fso.opentextfile("c:\" & strIP & ".txt")
  macaddress = null
  Do While Not ts.AtEndOfStream
  data = ucase(trim(ts.readline))
  If instr(data,"MAC ADDRESS") Then
  macaddress = trim(split(data,"=")(1))
  Exit Do
  End If
  loop
  ts.close
  Set ts = nothing
  fso.deletefile "c:\" & strIP & ".txt"
  Set fso = nothing
  GetMACAddress = macaddress
  strMac = GetMACAddress
  set conn=server.CreateObject("adodb.connection")
  conn.open "DSN=;UID=;PWD="
  dsnpath="DSN=;UID=;PWD="
  set rs=server.CreateObject("adodb.recordset")
  sele="select * from getmac where g_mac='"&strMac&"'"
  
  rs.open sele,dsnpath
  if rs.bof then
  set conn=server.CreateObject("adodb.connection")
  conn.open "DSN=;UID=;PWD="
  dsnpath="DSN=;UID=;PWD="
  set rs=server.CreateObject("adodb.recordset")
  g_id=mid(strIP,9)
  g_id=left(g_id,2)
  'response.write g_id
  if isnumeric(g_id) then
  g_id=cint(g_id)
  else
  g_id=0
  end if
  sele="insert into getmac(g_ip,g_mac,g_id,g_ok) values('"&strIP&"','"&strMac&"',"&g_id&",0)"
  rs.open sele,dsnpath
  else
  set conn=server.CreateObject("adodb.connection")
  conn.open "DSN=;UID=;PWD="
  dsnpath="DSN=;UID=;PWD="
  set rs=server.CreateObject("adodb.recordset")
  
  sele="select * from getmac where g_ip='"&trim(strIP)&"' and g_mac='"&trim(strMac)&"'"
  rs.open sele,dsnpath
  
  if rs.bof or rs.eof then
  set rs1=server.CreateObject("adodb.recordset")
  sele="insert into badmac(ip, mac ,thetime) values('"&strIP&"','"&strMac&"','"&now()&"')"
  rs1.open sele,dsnpath
  response.redirect("/reg/wrong.asp")
  response.end
  end if
  end if
  %＞
  ＜html＞
  ＜head＞
  ＜link rel="stylesheet" type="text/css" href="/css/FORUM.CSS"＞
  ＜style type=text/css＞
  ＜!--
  input { font-size: 9pt; color: #0011dd; background-color: #e9e9f9; padding-top: 0px}
  select { font-size: 9pt; color: #0011dd; background-color: #e9e9f9; padding-top: 0px}
  textarea { font-size: 9pt; color: #0011dd; background-color: #e9e9f9; padding-top: 0px}
  --＞
  ＜/style＞
  ＜title＞邮件系统＜/title＞＜/head＞＜body bgcolor="#FEF7ED"＞
  ＜%
  Response.Expires=0
  Function bin2str(binstr)
  Dim varlen,clow,ccc,skipflag
  
  skipflag=0
  ccc = ""
  If Not IsNull(binstr) Then
  varlen=LenB(binstr)
  For i=1 To varlen
  If skipflag=0 Then
  clow = MidB(binstr,i,1)
  If AscB(clow) ＞ 127 Then
  ccc =ccc & Chr(AscW(MidB(binstr,i+1,1) & clow))
  skipflag=1
  Else
  ccc = ccc & Chr(AscB(clow))
  End If
  Else
  skipflag=0
  End If
  Next
  End If
  bin2str = ccc
  End Function
  
  
  varByteCount = Request.TotalBytes
  'response.write varbytecount
  
  bnCRLF = chrB( 13 ) & chrB( 10 )
  
  binHTTPHeader=Request.BinaryRead(varByteCount)
  
  'response.write vbenter
  'response.write "
  
  "& cstr(binhttpheader) &"
  
  "
  
  
  sread=0
  eread=0
  
  
  '开始读非文件域的数据
  set conn = Server.CreateObject("ADODB.Connection")
  conn.open "DSN=;UID=;PWD="
  
  SQL="select * from t_mail where mailid=0"
  set rs=server.CreateObject("ADODB.Recordset")
  rs.Open sql,conn,3,3
  rs.addnew
  rs("emaillevel")=0
  rs("receempl")=""
  Do while lenB(binHTTPHeader)＞46
  
  Divider = LEFTb( binHTTPHeader, INSTRB( binHTTPHeader, bnCRLF ) - 1 )
  binHeaderData = Leftb(binHTTPHeader, INSTRB( binHTTPHeader, bnCRLF & bnCRLF )-1)
  strHeaderData=bin2str(binHeaderData)
  
  lngFieldNameStart=Instr(strHeaderData,"name="&chr(34))+Len("name="&chr(34))
  'response.write "
  lngfieldnamestart:"&lngfieldnamestart
  lngFieldNameEnd=Instr(lngFieldNameStart,strHeaderData,chr(34))
  'response.write "
  lngfieldnameEND:"&lngfieldnameEND
  
  
  strFieldName=Mid(strHeaderData,lngFieldNameStart,lngFieldNameEnd-lngFieldNameStart)
  
  'RESPOnSE.WRITE "＜BR＞STRFIELDNAME:" & STRfieldname
  
  
  strFieldName=Trim(strFieldName)
  
  
  strFieldName=Replace(strFieldName,vbcrlf,vbnullstring)
  
  '判断文件数据时候开始
  
  If strComp(strFieldName,"FileUploadStart",1)=0 and sread=0 Then
  'response.write "找到了文件开始的地方"
  sread=1
  'response.write "
  " & INSTRB( DataStart + 1, binHTTPHeader, divider ) &"
  "
  binHTTPHeader=MIDB(binHTTPHeader,INSTRB( DataStart + 1, binHTTPHeader, divider ))
  exit do
  End if
  DataStart = INSTRB( binHTTPHeader, bnCRLF & bnCRLF ) + 4
  DataEnd = INSTRB( DataStart + 1, binHTTPHeader, divider ) - DataStart
  
  binFieldValue=MIDB( binHTTPHeader, DataStart, DataEnd )
  strFieldValue=bin2str(binFieldValue)
  
  'strFieldValue=Trim(strFieldValue)
  
  strFieldValue=Replace(strFieldValue," "," ")
  
  '非文件上传域变量赋值
  'execute strFieldName&"="""&strFieldValue&""""
  'response.write strFieldName&":"&strFieldValue&"
  "
  
  if strfieldname="geterempl" then
  strFieldValue=Replace(strFieldValue,vbcrlf,vbnullstring)
  if instr(strfieldvalue,"gr:")=1 then
  '邮件组发
  
  'response.write len(trim(strfieldvalue))
  if len(trim(strfieldvalue))＜＞6 then
  '格式错误返回
  %＞
  
  尝试发送邮件，但是失败了，请修改错误后重试！
  ＜script language="javascript"＞
  alert("您输入的收件组格式错误！\r正确的格式是:'