www.gusucode.com > 漂亮的地方旅游景点景观介绍网站源代码 > admin/inc/fun.asp
<!--#include virtual="/inc/function.asp" -->
<%
'//////////////////////////////////////////////////////////////
Private function outhtml(str)
dim stemp
stemp = str
outhtml = ""
if isnull(stemp) = true then
exit function
end if
stemp = replace(stemp, "&", "&")
stemp = replace(stemp, "<", "<")
stemp = replace(stemp, ">", ">")
stemp = replace(stemp, chr(34), """)
stemp = replace(stemp, chr(10), "<br>")
outhtml = stemp
end function
'生成排序号/////////////////////////////////////////////////////////////////////
Private function scpx(tbl,fidx)
dim pxrs
call record(pxrs,"select top 1 * from "&tbl&" where fid="&fidx&" order by qz desc",1)
if pxrs.eof then
scpx=1
else
scpx=pxrs("qz")+1
end if
call recordend(pxrs)
end function
'生成排序号///////////////////////////////////////////////////////////////////////
Private function scpx1(tbl)
dim pxrs
call record(pxrs,"select top 1 * from "&tbl&" order by qz desc",1)
if pxrs.eof then
scpx1=1
else
scpx1=pxrs("qz")+1
end if
call recordend(pxrs)
end function
'生成点击次数///////////////////////////////////////////////////////////////////
Private function gethits()
dim hitscs,hits
hitscs=500
randomize
gethits=int((hitscs+1)*rnd+hitscs)
end function
'删除文件//////////////////////////////////////////////////////////////////////
Private sub delfile(dpic)
Dim fso
if dpic<>"" and instr(dpic,"//")=0 then
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(pdlj(dpic))=true Then
fso.DeleteFile(pdlj(dpic))
End If
Set fso = Nothing
conn.execute("delete * from Jw_upfile where path='"&dpic&"'")
end if
End sub
Private sub head()
Response.Write("<html><head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""><title>"&sitename&"--"&mytit&"</title></head><body>")
end sub
Private sub foot()
Response.Write("</body></html>")
end sub
'级数//////////////////////////////////////////////////////////////////////////
Private function getjs(tab)
dim fpath,path
fpath=getmc(tab,"id",fid,"fpath")
path=split(fpath,",")
getjs=ubound(path)
end function
'导航条/////////////////////////////////////////////////////////////////////
Private function getlmdh(tab,id)
dim path
path=split(getmc(tab,"id",id,"fpath"),",")
dim x
for x=0 to ubound(path)-1
if not path(x)="" and not path(x)=0 then
getlmdh=getlmdh&getmc(tab,"id",path(x),"mc")
if not x=ubound(path)-1 then
getlmdh=getlmdh&" > "
end if
end if
next
end function
'生成OPTION/////////////////////////////////////////////////////////////////////////////
Private sub getoption(tab,zj,zd,xz)
dim rso
set rso=conn.execute("select * from "&tab&" order by "&zj&" asc")
do while not rso.eof
Response.Write("<option value="""&rso(zj)&"""")
if xz<>"" then
if int(xz)=int(rso(zj)) then
Response.Write(" selected")
end if
end if
Response.Write(">"&rso(zd)&"</option>"&vbcrlf)
rso.movenext
loop
rso.close
set rso=nothing
end sub
'文件夹是否存在，不存在则生成////////////////////////////////////////////////////////////
Private sub cacfol(FolderName)
dim fldr,fso
fldr=pdlj(FolderName)
Set fso=server.CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fldr) Then
call AutoMaticCreation(FolderName)
End If
Set fso=Nothing
End sub
Private sub AutoMaticCreation(strPath)
On Error Resume Next
Dim astrPath, ulngPath, i, strTmpPath
Dim objFSO
strPath = pdlj(strPath)
strPath=Replace(strPath, "\", "/")
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strPath) Then
Exit sub
End If
astrPath = Split(strPath, "/")
ulngPath = UBound(astrPath)
strTmpPath = ""
For i = 0 To ulngPath
strTmpPath = strTmpPath & astrPath(i) & "/"
If Not objFSO.FolderExists(strTmpPath) Then
objFSO.CreateFolder(strTmpPath)
End If
Next
Set objFSO = Nothing
End sub
'分类文件夹/////////////////////////////////////////////////////////////////////////////
Private function getclassfol(tab,fid,ename)
getclassfol="/html/"
dim fpath,fol,fstr,i
if fid=0 then
fol=ename&"/"
else
fpath=getmc(tab,"id",fid,"fpath")
fstr=split(fpath,",")
for i=1 to ubound(fstr)-1
fol=fol&getmc(tab,"id",fstr(i),"ename")&"/"
next
fol=fol&ename&"/"
end if
getclassfol=getclassfol&fol
end function
'文件夹是否存在////////////////////////////////////////////////////////////
Private function cacfols(FolderName)
dim fldr,fso
fldr=pdlj(FolderName)
Set fso=CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fldr) Then
cacfols=false
else
cacfols=true
End If
Set fso=Nothing
End function
'删除文件夹////////////////////////////////////////////////////////////////////////////
Private sub delfol(Folder)
dim fso
Folder=pdlj(Folder)
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
if FSO.FolderExists(Folder) then
FSO.Deletefolder Folder,true
end if
if err>0 then
err.clear
end if
end sub
'本月文件夹名//////////////////////////////////////////////////////////////////////////
Private function getfolname()
getfolname=year(now())
if len(month(now()))=1 then
getfolname=getfolname&"0"&month(now())
else
getfolname=getfolname&month(now())
end if
end function
'获取上传文件名////////////////////////////////////////////////////////////////////////
Private function getfilename()
dim ranNum
dim dtNow
dtNow=Now()
randomize
ranNum=int(90*rnd)+10
getfilename=year(dtNow)&right("0"&month(dtNow),2)&right("0"&day(dtNow),2)&right("0"&hour(dtNow),2)& right("0"&minute(dtNow),2)&right("0"&second(dtNow),2)&ranNum
end function
'文件改名////////////////////////////////////////////////////////////////////////////////
Private sub cgfilename(yname,newname)
dim fs,sfile,nfile
Set fs = Server.CreateObject("Scripting.FileSystemObject")
SFile = yname
NFile = newname
on Error Resume Next
fs.MoveFile SFile, NFile
If Err.Number=53 Then
Response.Write File&"文件不存在！"
Response.End
Elseif Err.Number=58 Then
Response.Write File&"文件已存在！"
Response.End
Elseif Err.Number<>0 Then
Response.Write "未知错误，错误编码："&Err.Number
Response.End
End If
end sub
'ASPJPEG生成缩略图///////////////////////////////////////////////////////////////////////
Private sub getslt(path,path1)
dim jpeg,bl
Set Jpeg=Server.CreateObject("Persits.Jpeg")
Jpeg.Open(pdlj(Path))
select case sltlx
case 0
Jpeg.Width=swidth
Jpeg.Height=sheight
case 1
Jpeg.Width=Jpeg.OriginalWidth*sltbl
Jpeg.Height=Jpeg.OriginalHeight*sltbl
case 2
Jpeg.Width=swidth
bl=Jpeg.OriginalWidth/swidth
Jpeg.Height=Jpeg.OriginalHeight/bl
case 3
Jpeg.Height=sheight
bl=Jpeg.OriginalHeight/sHeight
Jpeg.Width=Jpeg.OriginalWidth/bl
end select
Jpeg.Save pdlj(path1)
conn.execute("insert into Jw_upfile (path,filesize,ctim,ext) values ('"&path1&"',"&getfilesize(pdlj(path1))&",now(),'"&fileexec(path1)&"')")
set jpeg=nothing
end sub
Private sub picsy(pic)
if pic<>"" then
dim photo,spic,logo
sypic=pdlj(sypic)
Set Photo = Server.createObject("Persits.Jpeg")
spic=pdlj(pic)
Photo.Open(spic)
' 建立LOGO对象
Set Logo = Server.createObject("Persits.Jpeg")
' 打开LOGO
Logo.Open sypic
' 设置LOGO大小
Logo.Width=picwidth
Logo.Height=picheight
' 缩略图大小
' 设置图片水印位置，LOGO 透明度，抽取 LOGO 背景颜色(白色)，并删除
Photo.DrawImage (Photo.Width-syx-picwidth),(Photo.Height-syy-picheight),Logo,sytmd,&HFFFFFF
' 保存文件
Photo.Save(spic)
' 注销对象
Set Photo=nothing
end if
end sub
Private sub textsy(pic)
if pic<>"" then
dim LocalFile,TargetFile,jpeg,myjpeg,logo
LocalFile=pdlj(pic)
TargetFile=pdlj(pic)
Set Jpeg = Server.CreateObject("Persits.Jpeg")
If Err.Number=-2147221005 then
Response.write "没有这个组件，请安装!"'检查是否安装AspJpeg组件
Response.End()
End If
Jpeg.Open (LocalFile)'打开图片
If err.number then
Response.write"打开图片失败,请检查路径！"
Response.End()
End if
Dim TempA '原始图片的二进制数据
Dim TempB '加了不透明文字水印的图片
Dim TempC '最终效果
TempA=Jpeg.Binary'将原始数据赋给TempA
'=========加文字水印=================
Jpeg.Canvas.Font.Color = &Hfffffff'水印文字颜色
Jpeg.Canvas.Font.Family = "Arial"'字体
if syb=1 then
Jpeg.Canvas.Font.Bold = True'是否加粗
end if
Jpeg.Canvas.Font.Size = sytextsize'字体大小
Jpeg.Canvas.Font.ShadowColor = &H000000'阴影色彩
Jpeg.Canvas.Font.ShadowYOffset=1
Jpeg.Canvas.Font.ShadowXOffset=1
Jpeg.Canvas.Brush.Solid = True
Jpeg.Canvas.Font.Quality = 5'输出质量
Jpeg.Canvas.PrintText ((jpeg.width/2)-syx),((jpeg.height/2)-syy),sytext'水印位置及文字
TempB=Jpeg.Binary'将文字水印处理后的值赋给TempB，这时，文字水印没有不透明度
'============调整文字透明度================
Set MyJpeg = Server.CreateObject("Persits.Jpeg")
MyJpeg.OpenBinary TempA
Set Logo = Server.CreateObject("Persits.Jpeg")
Logo.OpenBinary TempB
MyJpeg.DrawImage 0,0, Logo, 0.5
TempC=MyJpeg.Binary'将最终结果赋值给TempC,这时也可以生成目标图片了
'response.BinaryWrite TempC'将二进输出给浏览器
MyJpeg.Save (TargetFile)
set TempA=nothing
set TempB=nothing
set TempC=nothing
Jpeg.close
MyJpeg.Close
Logo.Close
end if
end sub
'获取文件大小////////////////////////////////////////////////////////////////////////////////
Private function getfilesize(pic)
if pic<>"" then
dim fso,objfso
set fso=server.CreateObject("scripting.FileSystemObject")
Set objfso=fso.Getfile(pic)
getfilesize=objfso.size
set objfso=nothing
set fso=nothing
end if
end function
'返回信息
Private sub errs(str)
call connend()
response.Clear()
Response.Write(escape(str))
response.End()
end sub
'文件夹改名/////////////////////////////////////////////////////////////////////////////////
Private sub fldrename(nowfld,newfld)
nowfld=pdlj("/"&nowfld)
newfld=pdlj("/"&newfld)
on error resume next
Set fso = CreateObject("Scripting.FileSystemObject")
if not fso.FolderExists(nowfld) then
call cc("需要修改的文件夹路径不正确或文件夹名称输入错误")
else
fso.CopyFolder nowfld,newfld
fso.DeleteFolder(nowfld)
end if
set fso=nothing
End sub
'判断是否物理路径///////////////////////////////////////////////////////////////////////////
Private function pdlj(lj)
if lj<>"" then
lj=lcase(lj)
lj=replace(lj,"\","/")
if left(lj,1)<>"/" and left(lj,1)<>"." and instr(lj,":")=2 then
'是物理路径
pdlj=lj
else
'response.Write(lj)
'response.End()
pdlj=server.MapPath(lj)
end if
else
exit function
end if
end function
'添加文件///////////////////////////////////////////////////////////////////////////////////
Private sub addpic(pic)
if pic<>"" then
conn.execute("insert into jw_upfile (path,ctim,filesize,ext) values ('"&pic&"',now(),"&getfilesize(pdlj(pic))&",'"&fileexec(pic)&"')")
end if
end sub
'处理关键字///////////////////////////////////////////////////////////////////////////////
Private function clgjz(gjzstr)
if gjzstr<>"" then
clgjz=""
dim gstr,j
gstr=split(gjzstr,",")
for j=0 to ubound(gstr)
if trim(gstr(j))<>"" then
call record(rs,"select * from Jw_newskey where mc='"&trim(gstr(j))&"'",3)
if rs.eof then
rs.addnew
rs("mc")=trim(gstr(j))
rs("hits")=0
rs.update
clgjz=clgjz&rs("id")&","
else
clgjz=clgjz&rs("id")&","
end if
call recordend(rs)
end if
next
if clgjz<>"" then
clgjz=left(clgjz,len(clgjz)-1)
end if
end if
end function
sub tssx(sx1,sx2)
if sx1=1 then
Response.Write("<span class=""fontr"">[置顶]<span>")
end if
if sx2=1 then
Response.Write("<span class=""fontr"">[禁用]<span>")
end if
end sub
sub chkqx(a,b)
dim qx
qx=request.cookies(fmid)("qx"&a)
if instr(qx,","&b&",")=0 then
call cc("对不起！您没有访问该页的权限")
end if
end sub
function chkemail(str)
dim chk
chk=true
if instr(str,".")=0 then
chk=false
end if
if instr(str,"@")=0 then
chk=false
end if
if instr(str,".")=1 then
chk=false
end if
if instr(str,"@")=1 then
chk=false
end if
if instr(str,".")=len(str) then
chk=false
end if
if instr(str,"@")=len(str) then
chk=false
end if
if instr(str,"@")>instr(str,".") then
chk=false
end if
chkemail=chk
end function
sub dopx(tab,xid,sid,nid)
if getnum( tab&" where fid="&xid&" and qz="&nid)>0 then
conn.execute("update "&tab&" set qz=qz+1 where fid="&xid&" and qz>="&nid)
end if
conn.execute("update "&tab&" set qz="&nid&" where id="&sid)
end sub
%>