pop3func.asp

办公自动化系统 适用于办公室的各种几本功能的操作 功能比较简单

<%
Sub AddPop3(UserID,Pop3Server,UserName,UserPwd,TimeOut,SaveBackup,NameOut)
	if UserID<>"" and Pop3Server<>"" and UserName<>"" and UserPwd<>"" and NameOut<>"" then
		dim RsTmp, strSQL
		Set RsTmp=Server.CreateObject("Adodb.Recordset")
		strSQL="Select * from tblUserPop3 where UserID="& UserID &" and Pop3Server='"& Pop3Server&"' and Pop3Name='"& UserName &"'"
		RsTmp.open strSql,Conn
		if not RsTmp.eof then
			Response.write "已经存在该帐号！"
		else
			strSQL="Insert into tblUserPop3 (UserID,Pop3Server,Pop3Name,Pop3Pwd,Pop3Timeout,Nameout,SaveBackup) values("& UserID & _
			",'"& Pop3Server & _
			"','"& UserName & _
			"','"& UserPwd & _
			"','"& TimeOut & _
			"','"& NameOut & _
			"',"& SaveBackup & _
			")"
			Conn.execute strSQL
		end if			
		RsTmp.close
		Set RsTmp = Nothing
	else
	response.write "数据不完整！"
	response.end
	end if
End Sub


Sub UpdatePop3(PopID,UserID,Pop3Server,UserName,UserPwd,TimeOut,SaveBackup,NameOut)
	if PopID<>"" and UserID<>"" and Pop3Server<>"" and UserName<>"" and UserPwd<>"" then
		dim RsTmp, strSQL
		Set RsTmp=Server.CreateObject("Adodb.Recordset")
		strSQL="Select * from tblUserPop3 where ID<>"& PopID &" and UserID="& UserID &" and Pop3Server='"& Pop3Server&"' and Pop3Name='"& UserName &"'"
		RsTmp.open strSql,Conn
		if not RsTmp.eof then
			Response.write "已经存在该帐号！"
		else
			strSQL="Update tblUserPop3 set Pop3Server='"& Pop3Server&"',Pop3Name='"& UserName &"',Pop3Pwd='"& UserPwd &"',Pop3Timeout='"& TimeOut &"',SaveBackup="& SaveBackup &",NameOut='"& nameout &"' where ID=" & PopID
			'response.write strsql
			Conn.execute strSQL
		end if			
		RsTmp.close
		Set RsTmp = Nothing
	else
		response.write "参数不完整！"
	end if
End Sub

Sub DelPop3(ID,UserID)
	if ID<>"" and UserID<>"" then
		Conn.execute "Delete tblUserPop3 where ID="& ID &" and UserID="& UserID
	end if
End Sub

Sub GetMails(UserID,Pop3Server,Pop3Name,Pop3Pwd,TimeOut,SaveBackup)
if UserID<>"" and Pop3Server<>"" and Pop3Name<>"" and Pop3Pwd<>"" then
	strThisDir=Server.Mappath("../File_Up/Pop3Mail/"&UserID)
	set FileObject = server.createobject("Scripting.FileSystemObject")
	if not FileObject.FolderExists(strThisDir) then
	   FileObject.CreateFolder strThisDir
	end if
	set FileObject = nothing

	'response.write "<p>正在接收在 "& pop3Server &" 上的邮件...</p>"

	strSendTo=pop3Name&"@"&Pop3Server
	Set Mailer = Server.CreateObject("POP3svg.Mailer")
	Mailer.RemoteHost  = pop3Server
	Mailer.UserName = Pop3Name
    Mailer.Password = Pop3Pwd

	'Mailer.TimeOut = TimeOut
	'Mailer.OpenPop3
	if Mailer.GetPopHeaders then
		varArray = Mailer.MessageInfo
		if VarType(varArray) <> vbNull And IsEmpty(varArray) <>  True then
			ArrayLimit = UBound(varArray)
            Response.Write "<table border=0 width=""99%"" bgcolor=#000000 cellspacing=1 cellpadding=3>"
			Response.Write "<tr bgcolor=#ffffff>"
			  Response.Write "<td width='30%'><b>" & "主题" & "<b></td>"
			  Response.Write "<td width='22%'><b>" & "日期" & "<b></td>"
			  Response.Write "<td width='30%'><b>" & "发件人" & "<b></td>"
			  Response.Write "<td width='10%'><b>" & "大小" & "<b></td>"
			  Response.Write "<td width='8%'><b>" & "附件" & "<b></td>"
			  Response.Write "</tr>"
			n=0
			For I = 0 to ArrayLimit
				strMsgNo = Trim(varArray(I)(0))
				
				Mailer.OpenPop3
				Mailer.Retrieve strMsgNo
				strMessageID = trim(Mailer.MessageID)
				Mailer.ClosePop3
				
				set rspop2=server.createobject("adodb.recordset")
				sql="select * from tblPop3recieved where SendTo='"& strSendTo &"' and userID="& UserID &" and MessageID='"& strMessageID &"'"
				
				rspop2.open sql,Conn
				if not rspop2.eof then
					bRecieved=true
				else
					bRecieved=false
				end if
				rspop2.close
				set rspop2=nothing
				if not bRecieved then

					strSubject = trim(varArray(I)(1))
					if trim(strSubject) = "" or strSubject=vbNull then strSubject = "(无主题)"
					strDate = trim(varArray(I)(2))
					strFrom = trim(varArray(I)(3))
					strSender=trim(varArray(I)(4))
					strReplyto=trim(varArray(I)(6))
					strSize=trim(varArray(I)(7))
					strStatus=varArray(I)(8)
					nPriority=Mailer.Priority
					if nPriority="1" then
						strPriority="高"
					elseif nPriority="3" then
						strPriority="普通"
					elseif nPriority="5" then
						strPriority="低"
					end if
					strBodyText = replace(FixUpItems(Mailer.BodyText),"'","''")
					strCC= server.htmlencode(Trim(Mailer.CC))
					if strCC="" or strCC=vbNull then strCC="none" 
					strRecipients = FixUpItems(Mailer.Recipients)
					strFromName = trim(Mailer.FromName)
					strFromAddress = trim(Mailer.FromAddress)
					strEncoding= trim(Mailer.Encoding)
				
					n=n+1				
					
					
					AddPop3Mail LoginID,strBodyText,strCC,strEncoding,strFromAddress,strFromname,strPriority,strDate,strSubject,strSize
					
					newMailID=NewID			

					strMailDir=Server.mappath("../File_up/pop3Mail/"&UserID&"/"&newMailID)
					set FileObject = server.createobject("Scripting.FileSystemObject")
					if not FileObject.FolderExists(strMailDir) then
					   FileObject.CreateFolder strMailDir
					end if
					set FileObject = nothing
					Mailer.MailDirectory = strMailDir
					nAttachCount = Mailer.AttachmentCount

					if nAttachCount > 0 then
					  strFileName=""
					  strAttContentType=""
					  strFileSize=""
					  For intCount = 1 to nAttachCount
						if Mailer.GetAttachmentInfo (intCount) then
							strFileName=strFileName&","&Mailer.AttFileName
							strAttContentType=strAttContentType&","&Mailer.AttContentType
							strFileSize=strFileSize&","& Mailer.AttFileSize
							Mailer.SaveAttachment (intCount)
						end if
					  Next
					  strFileName=right(trim(strFileName),len(strFileName)-1)
					  strAttContentType=right(trim(strAttContentType),len(strAttContentType)-1)
					  strFileSize=right(trim(strFileSize),len(strFileSize)-1)
					  Conn.execute "update tblPop3Mail set AttachmentCount="& nAttachCount &", AttFileName='"& strFileName &"',attContentType='"& strAttContentType &"',attFileSize='"& strFileSize &"' where ID="& newMailID
					  
					end if
					
					if SaveBackup="0" then
						Mailer.OpenPop3						
						Mailer.Delete strMsgNo
						Mailer.ClosePop3
					else
						AddPop3MessageID LoginID,strMessageID,strSendTo
					end if
					  
					  Response.Write "<tr bgcolor=#ffffff>"
					  Response.Write "<td><a href=PopMailDetail.asp?ID="&newMailID&">" & strSubject & "</a></td>"
					  Response.Write "<td>" & strDate & "</td>"
					  Response.Write "<td>" & trim(strFrom)&"("&strFromAddress&")"&"</td>"
					  if strSize<1200 then
						Response.Write "<td>" & strSize & "</td>"
					  else
						 Response.Write "<td>" & FormatNumber(strSize/1000,2) & "Kb</td>"
					  end if
					  if nAttachCount>0 then
						Response.Write "<td><img src='../Images/attach.gif' border=0></td>"
					  else
						 Response.Write "<td></td>"
					  end if
					  Response.Write "</tr>"
				end if
			next
			Response.Write "</table>"
			response.write "<p><font color=#111177>"& Pop3Name &" 在 "& Pop3Server &" 上有 "& n &" 封新邮件保存。</font></p>"
			
		else
			response.write "<p><font color=#bb1111>"& Pop3Name &" 在 "& Pop3Server &" 上有没有新邮件。</font></p>"
		end if
	else
		response.write "<p><font color=#bb1111>无法连接"& Pop3server &"，请确认用户名或口令是否正确！</font></p>"
	end if
	
	Set Mailer = nothing
end if
End Sub

Sub AddPop3Mail(UserID,strBodyText,strCC,strEncoding,strFromAddress,strFromname,strPriority,strDate,strSubject,strSize)
	sql="SET NOCOUNT ON;"
	sql=sql&" INSERT INTO tblpop3Mail(UserID,BodyText,CC,Encoding,FromAddress,FromName,Priority,DateTimes,Subject,Size) VALUES(" & UserID & _
		",'"& strBodyText & _
		"','"& strCC & _
		"','" & strEncoding & _
		"','"& strFromAddress & _
		"','"& strFromName & _
		"','"& strPriority & _
		"','"& strDate & _
		"','"& strSubject & _
		"','"& strSize & _
		"');"
		sql=sql & "Select @@IDENTITY AS NewID;"
		
		Set RsMail=Conn.execute (sql)
		NewID = RsMail("NewID")
End Sub

Sub AddPop3MessageID(UserID,MessageID,SendTo)
	sql=" INSERT INTO tblpop3Recieved(UserID,MessageID,SendTo) VALUES(" & UserID & _
		",'"& MessageID & _
		"','"& SendTo & _
		"');"
	
		Conn.execute (sql)
		
End Sub

function Subst (strValue, strOldValue, strNewValue)
    intLoc = InStr(strValue, strOldValue)
    While intLoc > 0
      if intLoc > 1 then
        if intLoc = Len(strValue) then
          strValue = Left(strValue, intLoc-1) & strNewValue
        else
          strValue = Left(strValue, intLoc -1) & strNewValue & Right(strValue, Len(strValue)-(intLoc-Len(strOldValue)+1))
        end if
      else
        strValue = strNewValue & Right(strValue, Len(strValue)-1)
      end if
      intLoc = InStr(strValue, strOldValue)
    Wend
    Subst = strValue
end function

function FixUpItems (strItem)
    if strItem <> "" then
      strItem = Subst(strItem, "<", "&lt;")
      strItem = Subst(strItem, ">", "&gt;")
      FixUpItems = strItem
    else
      FixUpItems = "<br>"
    end if
end function

sub DeleteOneFolder (FilePathName)
	FilePathName=Server.Mappath(FilePathName)
	dim fs
	Set fs = server.CreateObject("Scripting.FileSystemObject")
	if trim(FilePathName)<>"" and fs.FolderExists(FilePathName) then 
		fs.DeleteFolder FilePathName
	end if
	set fs=nothing	
end sub
%>