WEB源码(ASP,PHP,...)

开发平台：
ASP/ASPX

Function.asp：源码内容
							﻿<%
function advs(adid)
  dim rs,sql,i,ProductName,NewFlag
  set rs = server.createobject("adodb.recordset")
  sql="select * from sk_ADs where  ViewFlag  and id="&adid&" order by id desc"
  rs.open sql,conn,1,1
  if rs.bof and rs.eof then
    response.write "<div  align=center>暂无广告信息</div>"
  else
  if rs("fiewFlag")=0 then
  response.write"<div  align=center><a href='"&rs("Adurl")&"'><img src='"&rs("BigPic")&"' width='"&rs("ADsWidth")&"' height='"&rs("ADsHeight")&"' border='0' ></a></div>"
  else 
  response.write"<div  align=center><object classid='clsid:D27CDB6E-AE6D-11cf-96B8-444553540000' codebase='http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=7,0,19,0' width='"&rs("ADsWidth")&"' height='"&rs("ADsHeight")&"'>"
  response.write"<param name='movie' value='"&rs("BigPic")&"'>"
  response.write"<param name='quality' value='high'>"
  response.write"<param name='wmode' value='transparent' />"
  response.write"<embed src='"&rs("BigPic")&"' quality='high' pluginspage='http://www.macromedia.com/go/getflashplayer' type='application/x-shockwave-flash' width='"&rs("ADsWidth")&"' height='"&rs("ADsHeight")&"'></embed>"
  response.write"</object></div>"
  end if
  end if
  rs.close
  set rs=nothing
end function
function replaceText(str)
	dim regEx
	set regEx=New RegExp
	regEx.Pattern="<[^>]*>"
	regEx.Ignorecase=True
	regEx.Global=True
	replaceText=regEx.Replace(str,"")
End function
function cutstr(str,strlen)
if str<>"" then
	If len(replaceText(str))>strlen Then
		str=replace(str,"<P>","@p@")
		str=replace(str,"</P>","@1p@")
		str=replace(str,"<BR>","@BR@")
		str=left(replaceText(str),strlen)&"…"
		str=replace(str,"@p@","<p>")
		str=replace(str,"@1p@","</p>")
		str=replace(str,"@BR@","<br>")
	End If
end if
	cutstr=str
End function
function StrLen(Str)
  if Str="" or isnull(Str) then 
    StrLen=0
    exit function 
  else
    dim regex
    set regex=new regexp
    regEx.Pattern ="[^x00-xff]"
    regex.Global =true
    Str=regEx.replace(Str,"^^")
    set regex=nothing
    StrLen=len(Str)
  end if
end function
function StrLeft(Str,StrLen)
  dim L,T,I,C
  if Str="" then
    StrLeft=""
    exit function
  end if
  Str=Replace(Replace(Replace(Replace(Str,"&nbsp;"," "),"&quot;",Chr(34)),"&gt;",">"),"&lt;","<")
  L=Len(Str)
  T=0
  for i=1 to L
    C=Abs(AscW(Mid(Str,i,1)))
    if C>255 then
      T=T+2
    else
      T=T+1
    end if
    if T>=StrLen then
      StrLeft=Left(Str,i) & "…"
      exit for
    else
      StrLeft=Str
    end if
  next
  StrLeft=Replace(Replace(Replace(replace(StrLeft," ","&nbsp;"),Chr(34),"&quot;"),">","&gt;"),"<","&lt;")
end function
function StrReplace(Str)'表单存入替换字符
  if Str="" or isnull(Str) then 
    StrReplace=""
    exit function 
  else
    StrReplace=replace(str," ","&nbsp;") '"&nbsp;"
    StrReplace=replace(StrReplace,chr(13),"&lt;br&gt;")'"<br>"
    StrReplace=replace(StrReplace,"<","&lt;")' "&lt;"
    StrReplace=replace(StrReplace,">","&gt;")' "&gt;"
  end if
end function
function ReStrReplace(Str)'写入表单替换字符
  if Str="" or isnull(Str) then 
    ReStrReplace=""
    exit function 
  else
    ReStrReplace=replace(Str,"&nbsp;"," ") '"&nbsp;"
    ReStrReplace=replace(ReStrReplace,"<br>",chr(13))'"<br>"
    ReStrReplace=replace(ReStrReplace,"&lt;br&gt;",chr(13))'"<br>"
    ReStrReplace=replace(ReStrReplace,"&lt;","<")' "&lt;"
    ReStrReplace=replace(ReStrReplace,"&gt;",">")' "&gt;"
  end if
end function
function HtmlStrReplace(Str)'写入Html网页替换字符
  if Str="" or isnull(Str) then 
    HtmlStrReplace=""
    exit function 
  else
    HtmlStrReplace=replace(Str,"&lt;br&gt;","<br>")'"<br>"
  end if
end function
function ViewNoRight(GroupID,Exclusive)
  dim rs,sql,GroupLevel
  set rs = server.createobject("adodb.recordset")
  sql="select GroupLevel from sk_MemGroup where GroupID='"&GroupID&"'"
  rs.open sql,conn,1,1
  GroupLevel=rs("GroupLevel")
  rs.close
  set rs=nothing
  ViewNoRight=true
  if session("GroupLevel")="" then session("GroupLevel")=0
  select case Exclusive
    case ">="
      if not session("GroupLevel") >= GroupLevel then
	    ViewNoRight=false
	  end if
    case "="
      if not session("GroupLevel") = GroupLevel then
	    ViewNoRight=false
      end if
  end select
end function
Function GetUrl()
  GetUrl="http://"&Request.ServerVariables("SERVER_NAME")&Request.ServerVariables("URL")
  If Request.ServerVariables("QUERY_STRING")<>"" Then GetURL=GetUrl&"?"& Request.ServerVariables("QUERY_STRING")
End Function
function HtmlSmallPic(GroupID,PicPath,Exclusive)
  dim rs,sql,GroupLevel
  set rs = server.createobject("adodb.recordset")
  sql="select GroupLevel from sk_MemGroup where GroupID='"&GroupID&"'"
  rs.open sql,conn,1,1
  GroupLevel=rs("GroupLevel")
  rs.close
  set rs=nothing
  HtmlSmallPic=PicPath
  if session("GroupLevel")="" then session("GroupLevel")=0
  select case Exclusive
    case ">="
      if not session("GroupLevel") >= GroupLevel then HtmlSmallPic="../img/NoRight.jpg"
    case "="
      if not session("GroupLevel") = GroupLevel then HtmlSmallPic="../img/NoRight.jpg"
  end select
  if HtmlSmallPic="" or isnull(HtmlSmallPic) then HtmlSmallPic="../img/NoPicture.jpg"
end function
function IsValidMemName(memname)
  dim i, c
  IsValidMemName = true
  if not (3<=len(memname) and len(memname)<=16) then
    IsValidMemName = false
    exit function
  end if  
  for i = 1 to Len(memname)
    c = Mid(memname, i, 1)
    if InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-", c) <= 0 and not IsNumeric(c) then
      IsValidMemName = false
      exit function
    end if
  next
end function
function IsValidEmail(email)
  dim names, name, i, c
  IsValidEmail = true
  names = Split(email, "@")
  if UBound(names) <> 1 then
    IsValidEmail = false
    exit function
  end if
  for each name in names
	if Len(name) <= 0 then
	  IsValidEmail = false
      exit function
    end if
    for i = 1 to Len(name)
      c = Mid(name, i, 1)
      if InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-.", c) <= 0 and not IsNumeric(c) then
        IsValidEmail = false
        exit function
      end if
	next
	if Left(name, 1) = "." or Right(name, 1) = "." then
      IsValidEmail = false
      exit function
    end if
  next
  if InStr(names(1), ".") <= 0 then
    IsValidEmail = false
    exit function
  end if
  i = Len(names(1)) - InStrRev(names(1), ".")
  if i <> 2 and i <> 3 then
    IsValidEmail = false
    exit function
  end if
  if InStr(email, "..") > 0 then
    IsValidEmail = false
  end if
end function
'================================================
'函数名：FormatDate
'作　用：格式化日期
'参　数：DateAndTime            (原日期和时间)
'       Format                 (新日期格式)
'返回值：格式化后的日期
'================================================
Function FormatDate(DateAndTime, Format)
  On Error Resume Next
  Dim yy,y, m, d, h, mi, s, strDateTime
  FormatDate = DateAndTime
  If Not IsNumeric(Format) Then Exit Function
  If Not IsDate(DateAndTime) Then Exit Function
  yy = CStr(Year(DateAndTime))
  y = Mid(CStr(Year(DateAndTime)),3)
  m = CStr(Month(DateAndTime))
  If Len(m) = 1 Then m = "0" & m
  d = CStr(Day(DateAndTime))
  If Len(d) = 1 Then d = "0" & d
  h = CStr(Hour(DateAndTime))
  If Len(h) = 1 Then h = "0" & h
  mi = CStr(Minute(DateAndTime))
  If Len(mi) = 1 Then mi = "0" & mi
  s = CStr(Second(DateAndTime))
  If Len(s) = 1 Then s = "0" & s
   
  Select Case Format
  Case "1"
    strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
  Case "2"
    strDateTime = yy & m & d & h & mi & s
    '返回12位 直到秒 的时间字符串
  Case "3"
    strDateTime = yy & m & d & h & mi    
    '返回12位 直到分 的时间字符串
  Case "4"
    strDateTime = yy & "年" & m & "月" & d & "日"
  Case "5"
    strDateTime = m & "-" & d
  Case "6"
    strDateTime = m & "/" & d
  Case "7"
    strDateTime = m & "月" & d & "日"
  Case "8"
    strDateTime = y & "年" & m & "月"
  Case "9"
    strDateTime = y & "-" & m
  Case "10"
    strDateTime = y & "/" & m
  Case "11"
    strDateTime = y & "-" & m & "-" & d
  Case "12"
    strDateTime = y & "/" & m & "/" & d
  Case "13"
    strDateTime = yy & "." & m & "." & d
  Case Else
    strDateTime = DateAndTime
  End Select
  FormatDate = strDateTime
End Function
function WriteMsg(Message)
  response.write "<table width='400' border='0' align='center' cellpadding='1' cellspacing='1' bgcolor='#FF3300'>" &_
                 "  <tr>" &_
                 "    <td bgcolor='#FFFFFF'>" &_
                 "    <table width='100%' border='0' cellpadding='0' cellspacing='0' bgcolor='#FF3300'><tr>" &_
                 "      <td align='center' style='font-family:Arial;font-size:16px;color:#FFFFFF;font-weight:bold'>MESSAGE</td>" &_
                 "    </tr></table>" &_
                 "    </td>" &_
                 "  </tr>" &_
                 "  <tr>" &_
                 "    <td bgcolor='#FFFFFF' >" &_
                 "    <table width='100%' border='0' cellspacing='0' cellpadding='4'>" &_
                 "      <tr>" &_
                 "        <td bgcolor='#FFFFFF' style='font-family:Arial;font-size:12px;line-height:18px;color:#333333;'>" &_
				 Message &_
                 "        </td>" &_
                 "      </tr>" &_
                 "    </table>" &_
                 "	  </td>" &_
                 "	</tr>" &_
                 "</table>" &_
                 "<div align='center'>" &_
                 "<br>" &_
                 "<a href='javascript:history.back()'><img src='../img/Arrow_05.gif' width='22' height='22' border='0' /></a>" &_
                 "</div>"
end function
'****************************************************
'过程名：WriteErrMsg
'作  用：显示错误提示信息
'参  数：无
'****************************************************
sub WriteErrMsg()
	dim strErr
	strErr=strErr & "<html><head><title>错误信息_桂林在线</title><META HTTP-EQUIV='Content-Type' CONTENT='text/html; charset=utf-8' />" & vbcrlf
	strErr=strErr & "<link href='style.css' rel='stylesheet' type='text/css'></head><body>" & vbcrlf
	strErr=strErr & "<table cellpadding=2 cellspacing=2 border=0 width=400 class='border' align=center>" & vbcrlf
	strErr=strErr & "  <tr align='center'><td height='20' class='title'><strong>错误信息</strong></td></tr>" & vbcrlf
	strErr=strErr & "  <tr><td height='100' class='tdbg' valign='top'><b>产生错误的可能原因：</b><br>" & errmsg &"</td></tr>" & vbcrlf
	strErr=strErr & "  <tr align='center'><td class='title'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>" & vbcrlf
	strErr=strErr & "</table>" & vbcrlf
	strErr=strErr & "</body></html>" & vbcrlf
	response.write strErr
end sub
'****************************************************
'过程名：WriteSuccessMsg
'作  用：显示成功提示信息
'参  数：无
'****************************************************
sub WriteSuccessMsg(SuccessMsg)
	dim strSuccess
	strSuccess=strSuccess & "<html><head><title>成功信息_SK企业网站管理系统</title><META HTTP-EQUIV='Content-Type' CONTENT='text/html; charset=utf-8' />" & vbcrlf
	strSuccess=strSuccess & "<link href='style.css' rel='stylesheet' type='text/css'></head><body>" & vbcrlf
	strSuccess=strSuccess & "<table cellpadding=2 cellspacing=2 border=0 width=400 class='border' align=center>" & vbcrlf
	strSuccess=strSuccess & "  <tr align='center'><td height='20' class='title'><strong>恭喜你！</strong></td></tr>" & vbcrlf
	strSuccess=strSuccess & "  <tr><td height='100' class='tdbg' valign='top'><br>" & SuccessMsg &"</td></tr>" & vbcrlf
	strSuccess=strSuccess & "  <tr align='center'><td class='title'><a href='javascript:history.go(-1)'>【返回】</a></td></tr>" & vbcrlf
	strSuccess=strSuccess & "</table>" & vbcrlf
	strSuccess=strSuccess & "</body></html>" & vbcrlf
	response.write strSuccess
end sub
function getFileExtName(fileName)
    dim pos
    pos=instrrev(filename,".")
    if pos>0 then 
        getFileExtName=mid(fileName,pos+1)
    else
        getFileExtName=""
    end if
end function 
%>

						