?? function.asp
字號:
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function
'****************************************************
'函數名：SendMail
'作 用：用Jmail組件發送郵件
'參 數：ServerAddress ----服務器地址
' AddRecipient ----收信人地址
' Subject ----主題
' Body ----信件內容
' Sender ----發信人地址
'****************************************************
function SendMail(MailServerAddress,AddRecipient,Subject,Body,Sender,MailFrom)
on error resume next
Dim JMail
Set JMail=Server.CreateObject("JMail.SMTPMail")
if err then
SendMail= "<br><li>沒有安裝JMail組件</li>"
err.clear
exit function
end if
JMail.Logging=True
JMail.Charset="gb2312"
JMail.ContentType = "text/html"
JMail.ServerAddress=MailServerAddress
JMail.AddRecipient=AddRecipient
JMail.Subject=Subject
JMail.Body=MailBody
JMail.Sender=Sender
JMail.From = MailFrom
JMail.Priority=1
JMail.Execute
Set JMail=nothing
if err then
SendMail=err.description
err.clear
else
SendMail="OK"
end if
end function
'****************************************************
'過程名：WriteErrMsg
'作 用：顯示錯誤提示信息
'參 數：無
'****************************************************
sub WriteErrMsg()
dim strErr
strErr=strErr & "<html><head><title>錯誤信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & 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>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & 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
'==================================================
'過程名：ShowAnnounce
'作 用：顯示本站公告信息
' AnnounceNum ----最多顯示多少條公告
'==================================================
sub ShowAnnounce(AnnounceNum)
dim sqlAnnounce,rsAnnounce,i
if AnnounceNum>0 and AnnounceNum<=10 then
sqlAnnounce="select top " & AnnounceNum
else
sqlAnnounce="select top 10"
end if
sqlAnnounce=sqlAnnounce & " * from affiche order by ID Desc"
Set rsAnnounce= Server.CreateObject("ADODB.Recordset")
rsAnnounce.open sqlAnnounce,conn,1,1
if rsAnnounce.bof and rsAnnounce.eof then
AnnounceCount=0
response.write "<p> 沒有公告</p>"
else
AnnounceCount=rsAnnounce.recordcount
response.Write "本站公告："
do while not rsAnnounce.eof
response.Write " <a href='#' onclick=""javascript:window.open('Affiche.asp?ID=" & rsAnnounce("id") &"', 'newwindow', 'height=450, width=400, toolbar=no, menubar=no, scrollbars=auto, resizable=no, location=no, status=no')"" title='" & rsAnnounce("Content") & "'><font color='#FF0000'>" &rsAnnounce("title") & "</font></a>"
rsAnnounce.movenext
i=i+1
loop
end if
rsAnnounce.close
set rsAnnounce=nothing
end sub
'==================================================
'過程名：ShowFriendLinks
'作 用：顯示友情鏈接站點
'參 數：LinkType ----鏈接方式，1為LOGO鏈接，2為文字鏈接
' SiteNum ----最多顯示多少個站點
' Cols ----分幾列顯示
' ShowType ----顯示方式。1為向上滾動，2為橫向列表，3為下拉列表框
'==================================================
sub ShowFriendLinks(LinkType,SiteNum,Cols,ShowType)
dim sqlLink,rsLink,SiteCount,i,strLink
if LinkType<>1 and LinkType<>2 then
LinkType=1
else
LinkType=Cint(LinkType)
end if
if SiteNum<=0 or SiteNum>100 then
SiteNum=10
end if
if Cols<=0 or Cols>20 then
Cols=10
end if
if ShowType=1 then'
strLink=strLink & "<div id=rolllink style=overflow:hidden;height:100;width:100><div id=rolllink1>" '新增加的代碼
elseif ShowType=3 then
strLink=strLink & "<select name='FriendSite' onchange=""if(this.options[this.selectedIndex].value!=''){window.open(this.options[this.selectedIndex].value,'_blank');}""><option value=''>友情文字鏈接站點</option>"
end if
if ShowType=1 or ShowType=2 then
strLink=strLink & "<table width='100%' cellSpacing='5'><tr align='center' >"
end if
sqlLink="select top " & SiteNum & " * from FriendLinks where IsOK=True and LinkType=" & LinkType & " order by IsGood,id desc"
set rsLink=server.createobject("adodb.recordset")
rsLink.open sqlLink,conn,1,1
if rsLink.bof and rsLink.eof then
if ShowType=1 or ShowType=2 then
for i=1 to SiteNum
strLink=strLink & "<td>"
strLink=strLink & "</td>"
if i mod Cols=0 and i<SiteNum then
strLink=strLink & "</tr><tr align='center' >"
end if
next
end if
else
SiteCount=rsLink.recordcount
for i=1 to SiteCount
if ShowType=1 or ShowType=2 then
if LinkType=1 then
strLink=strLink & "<td width='88'><a href='" & rsLink("SiteUrl") & "' target='_blank' title='網站名稱：" & rsLink("SiteName") & vbcrlf & "網站地址：" & rsLink("SiteUrl") & vbcrlf & "網站簡介：" & rsLink("SiteIntro") & "'>"
if rsLink("LogoUrl")="" or rsLink("LogoUrl")="http://" then
strLink=strLink & "<img src='images/nologo.gif' width='88' height='31' border='0'>"
else
strLink=strLink & "<img src='" & rsLink("LogoUrl") & "' width='88' height='31' border='0'>"
end if
strLink=strLink & "</a></td>"
else
strLink=strLink & "<td width='88'><a href='" & rsLink("SiteUrl") & "' target='_blank' title='網站名稱：" & rsLink("SiteName") & vbcrlf & "網站地址：" & rsLink("SiteUrl") & vbcrlf & "網站簡介：" & rsLink("SiteIntro") & "'>" & rsLink("SiteName") & "</a></td>"
end if
if i mod Cols=0 and i<SiteNum then
strLink=strLink & "</tr><tr align='center' >"
end if
else
strLink=strLink & "<option value='" & rsLink("SiteUrl") & "'>" & rsLink("SiteName") & "</option>"
end if
rsLink.moveNext
next
if SiteCount<SiteNum and (ShowType=1 or ShowType=2) then
for i=SiteCount+1 to SiteNum
if LinkType=1 then
strLink=strLink & "<td width='88'></td>"
else
strLink=strLink & "<td width='88'></td>"
end if
if i mod Cols=0 and i<SiteNum then
strLink=strLink & "</tr><tr align='center' >"
end if
next
end if
end if
if ShowType=1 or ShowType=2 then
strLink=strLink & "</tr></table>"
end if
if ShowType=1 then
strLink=strLink & "</div><div id=rolllink2></div></div>" '新增代碼
elseif ShowType=3 then
strLink=strLink & "</select>"
end if
response.write strLink
if ShowType=1 then call RollFriendLinks() '新增代碼
rsLink.close
set rsLink=nothing
end sub
'==================================================
'過程名：RollFriendLinks
'作 用：滾動顯示友情鏈接站點
'參 數：無
'==================================================
sub RollFriendLinks()
%>
<script>
var rollspeed=30
rolllink2.innerHTML=rolllink1.innerHTML //克隆rolllink1為rolllink2
function Marquee(){
if(rolllink2.offsetTop-rolllink.scrollTop<=0) //當滾動至rolllink1與rolllink2交界時
rolllink.scrollTop-=rolllink1.offsetHeight //rolllink跳到最頂端
else{
rolllink.scrollTop++
}
}
var MyMar=setInterval(Marquee,rollspeed) //設置定時器
rolllink.onmouseover=function() {clearInterval(MyMar)}//鼠標移上時清除定時器達到滾動停止的目的
rolllink.onmouseout=function() {MyMar=setInterval(Marquee,rollspeed)}//鼠標移開時重設定時器
</script>
<%
end sub
%>
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -