<%@Language="vbscript"%>
<%
Response.CodePage=65001
Response.Charset="utf-8"
function responseEditor(msg)
%>
对不起！ "
else
response.write "网站内容管理 "
response.write ""
end if
response.write ""
end function
function responseUploadForm(msg)
response.write ""
response.write "对不起！ "
else
response.write "图片上传 "
response.write msg
response.write ""
response.write ""
else
responseLoginForm "提示：用户或口令不正确！"
end if
else
responseLoginForm "提示：验证码不正确！"
end if
response.end
elseif request("a")="e" then 'exit login session
session("用户名")=""
response.end
elseif request("a")="s" then 'page save
if session("用户名")<>"" then
filename=GetUpdateFileName()
CreateFolder "undo"'保存用于恢复的文件
CreateFolder "redo"'保存用于重做的文件
CreateFolder "upload"
'response.write server.MapPath(filename): response.end
call CopyAFile(server.MapPath(filename),server.MapPath(".") & "\undo\" & filename & "-" & Format_Time(now,6) ,true)
WriteToTextFile filename,request("c"),"utf-8"
response.Write("提示：保存成功！")
end if
response.end
elseif request("a")="ul" then 'into image upload page
responseUploadForm ""
response.end
elseif request("a")="uls" then 'image upload
if session("用户名")<>"" then
uploadret = updateAction()
savepath=GetJSONValue(uploadret,"url")
'response.Write(savepath)
response.write ""
'response.write ""
end if
response.end
elseif request("a")="undo" then '
filename=GetUpdateFileName()
'Set fso = CreateObject("Scripting.FileSystemObject")
'Set currentFile = fso.GetFile(filename)
newestFile=getNewestFile(server.MapPath(".") & "\undo\")
if newestFile<>"" then
'newestFileobj=fso.GetFile(newestFile)
'if newestFileobj.DateLastModified"" then
call CopyAFile(server.MapPath(filename),server.MapPath(".") & "\undo\" & filename & "-" & Format_Time(now,6) ,true)
call CopyAFile(newestFile,server.MapPath(filename) ,true)
deletefile newestFile
end if
response.end
elseif request("a")="editor" then '
responseEditor ""
response.end
elseif request("a")="getSafeCode" then '
Call CreateSafeCode()
response.end
elseif request("a")="t" then 'test
response.Write("c="&request("c") & "");
/*document.write("保存 | ");
document.write("退出 | ");
document.write("撤销 | ");
document.write("重做 | "); */
document.write(" ");
addAtt("p","contentEditable",true);
addAtt("div","contentEditable",true);
addAtt("h1","contentEditable",true);
addAtt("h2","contentEditable",true);
addAtt("img","contentEditable",true);
addAtt("img","ondblclick","img_ondblclick(this)");
//addAtt("p","onmouseup","onMymouseup(this)");
//addAtt("div","onmouseup","onMymouseup()");
}catch(err)
{
alert(err.message);
}
document.body.onmouseup=function(){
if(window.getSelection){
if(window.getSelection().toString()!==""){
if (!confirm('需要选区进行全文编辑吗？')){
exit;
}
var obj=new Object()
//obj.value=window.getSelection();
var selectionObj = window.getSelection();
var rangeObj = selectionObj.getRangeAt(0);
var docFragment = rangeObj.cloneContents();
var tempDiv = document.createElement("div");
tempDiv.appendChild(docFragment);
var selectedHtml = tempDiv.innerHTML;
obj.value=selectedHtml;
//range.setStart(selectionObject.anchorNode,selectionObject.anchorOffset);
//range.setEnd(selectionObject.focusNode,selectionObject.focusOffset);
var r=window.showModalDialog('cms.asp?a=editor',obj,"location:No;status:No;help:No;dialogWidth:500;dialogHeight:350;scroll:false;");
//alert(r);
if(r!=null && r!='undefined' && r!=''){
tempDiv = document.createElement("div");
tempDiv.innerHTML=r;
rangeObj.deleteContents();
rangeObj.insertNode(tempDiv);
}
window.getSelection().removeAllRanges()//用于清除高亮选中
document.selection.clear();用于清除选中内容
document.selection.empty()//用于清除高亮选中
}
}
else if(document.selection){
if(document.selection.createRange().text!==""){
alert("显示弹出框");
//document.selection.clear();用于清除选中内容
//document.selection.empty()//用于清除高亮选中
}
}
};
function onMymouseup()
{
var target = e.srcElement ? e.srcElement : e.target;
alert(e.selectionStart);
if (e.selectionStart != undefined && e.selectionEnd != undefined) {
var start = e.selectionStart;
var end = e.selectionEnd;
alert( e.value.substring(start, end));
}
}
function undo(src, width, height, showScroll){
try
{
ajaxrequest("cms.asp?a=undo&f="+escape(window.location.href),"post",true,null,function(){window.location.reload(true)},document);
}catch(err)
{
alert(err.message);
}
}
function redo(src, width, height, showScroll){
try
{
ajaxrequest("cms.asp?a=redo&f="+escape(window.location.href),"post",true,null,function(){window.location.reload(true)},document);
}catch(err)
{
alert(err.message);
}
}
function openWin(src, width, height, showScroll){
var r=window.showModalDialog (src,"","location:No;status:No;help:No;dialogWidth:"+width+";dialogHeight:"+height+";scroll:"+showScroll+";");
return r;
}
function img_ondblclick(src)
{
r=window.showModalDialog ('cms.asp?a=ul',null,"location:No;status:No;help:No;dialogWidth:400;dialogHeight:50;scroll:false;");
if(r!=null)
{
src.setAttribute("src",r);
window.opener.location.reload();
}
}
function addAtt(tagname,att,val)
{
var Sigma = document.getElementsByTagName(tagname);
for (var i = Sigma.length - 1; i >= 0; i--) {
Sigma[i].setAttribute(att,val);
}
}
function removeAtt(tagname,att)
{
var Sigma = document.getElementsByTagName(tagname);
for (var i = Sigma.length - 1; i >= 0; i--) {
Sigma[i].removeAttribute(att);
}
}
function getajaxHttp() {
var xmlHttp;
try {
// Firefox, Opera 8.0+, Safari
xmlHttp = new XMLHttpRequest();
} catch (e) {
// Internet Explorer
try {
xmlHttp = new ActiveXObject("Msxml2.XMLHTTP");
} catch (e) {
try {
xmlHttp = new ActiveXObject("Microsoft.XMLHTTP");
} catch (e) {
alert("您的浏览器不支持AJAX！");
return false;
}
}
}
return xmlHttp;
}
/**
* 发送ajax请求
* url--url
* methodtype(post/get)
* con (true(异步)|false(同步))
* parameter(参数)
* functionName(回调方法名，不需要引号,这里只有成功的时候才调用)
* (注意：这方法有二个参数，一个就是xmlhttp,一个就是要处理的对象)
* obj需要到回调方法中处理的对象
*/
function ajaxrequest(url,methodtype,con,parameter,functionName,obj){
var xmlhttp=getajaxHttp();
xmlhttp.onreadystatechange=function(){
if(xmlhttp.readyState==4){
//alert(xmlhttp.responseText);
//HTTP响应已经完全接收才调用
functionName(xmlhttp,obj);
}
};
xmlhttp.open(methodtype,url,con);
xmlhttp.setRequestHeader("Content-Type", "application/x-www-form-urlencoded");
xmlhttp.send(parameter);
}
//这就是参数
function createxml(){
var xml="asdfasdfasdf<\/userid><\/user>";//"\/"这不是大写V而是转义是左斜杠和右斜杠
return xml;
}
//这就是参数
function createjson(){
var json={id:0,username:"好人"};
return json;
}
function c(){
alert("");
}
//测试
//ajaxrequest("http://www.baidu.com","post",true,createxml(),c,document);
function savepage_ret(xmlhttp,obj)
{
alert(xmlhttp.responseText);
}
function savepage()
{
try
{
removeAtt("p","contentEditable");
removeAtt("div","contentEditable");
removeAtt("h1","contentEditable");
removeAtt("h2","contentEditable");
removeAtt("img","contentEditable");
removeAtt("img","ondblclick");
var kclb=s=document.getElementById("kfx_cms_area");
if(kclb)kclb.parentNode.removeChild(kclb);
var newContent="\n";
newContent+=document.head.outerHTML+"\n";
newContent+=document.body.outerHTML+"\n";
newContent+="<\/html>\n";
newContent=escape(newContent);//encodeURI
var para="a=s&f="+escape(window.location.href)+"&c="+newContent;
//alert(para);
//ajaxrequest("cms.asp?a=s&f="+escape(window.location.href)+"&c="+newContent,"post",true,null,savepage_ret,document);
ajaxrequest("cms.asp","post",true,para,savepage_ret,document);
}catch(err)
{
alert(err.message);
}
}
function exitlogin()
{
ajaxrequest("cms.asp?a=e","post",true,null,function(){window.location.reload();},document);
}
<%
response.end
else
%>
function openWin(src, width, height, showScroll){
var r=window.showModalDialog (src,"","location:No;status:No;help:No;dialogWidth:"+width+";dialogHeight:"+height+";scroll:"+showScroll+";");
return r;
}
document.write("登录<\/a>");
<%
end if
Function GetBrType() '获取浏览器类型(可以判断:47种浏览器;GoogLe,Grub,MSN,Yahoo!蜘蛛;十种常见IE插件)
Dim StrType, TheInfo, Tmp1, Sysver
GetBrType = "Other Unknown"
TheInfo = UCase(Request.ServerVariables("HTTP_USER_AGENT"))
if Instr(TheInfo,UCase("mozilla"))>0 then GetBrType = "Mozilla"
if Instr(TheInfo,UCase("icab"))>0 then GetBrType = "iCab"
if Instr(TheInfo,UCase("lynx"))>0 then GetBrType = "Lynx"
if Instr(TheInfo,UCase("links"))>0 then GetBrType = "Links"
if Instr(TheInfo,UCase("elinks"))>0 then GetBrType = "ELinks"
if Instr(TheInfo,UCase("jbrowser"))>0 then GetBrType = "JBrowser"
if Instr(TheInfo,UCase("konqueror"))>0 then GetBrType = "konqueror"
if Instr(TheInfo,UCase("wget"))>0 then GetBrType = "wget"
if Instr(TheInfo,UCase("ask jeeves"))>0 or Instr(TheInfo,UCase("teoma"))>0 then GetBrType = "Ask Jeeves/Teoma"
if Instr(TheInfo,UCase("wget"))>0 then GetBrType = "wget"
if Instr(TheInfo,UCase("opera"))>0 then GetBrType = "opera"
if Instr(TheInfo,UCase("NOKIAN"))>0 then GetBrType = "NOKIAN(诺基亚手机)"
if Instr(TheInfo,UCase("SPV"))>0 then GetBrType = "SPV(多普达手机)"
if Instr(TheInfo,UCase("Jakarta Commons"))>0 then GetBrType = "Jakarta Commons-HttpClient"
if Instr(TheInfo,UCase("Gecko"))>0 then
StrType = "[Gecko] "
GetBrType = "Mozilla Series"
if Instr(TheInfo,UCase("aol"))>0 then GetBrType = "AOL"
if Instr(TheInfo,UCase("netscape"))>0 then GetBrType = "Netscape"
if Instr(TheInfo,UCase("firefox"))>0 then GetBrType = "FireFox"
if Instr(TheInfo,UCase("chimera"))>0 then GetBrType = "Chimera"
if Instr(TheInfo,UCase("camino"))>0 then GetBrType = "Camino"
if Instr(TheInfo,UCase("galeon"))>0 then GetBrType = "Galeon"
if Instr(TheInfo,UCase("k-meleon"))>0 then GetBrType = "K-Meleon"
GetBrType = StrType & GetBrType
end if
if Instr(TheInfo,UCase("bot"))>0 or Instr(TheInfo,UCase("crawl"))>0 then
StrType = "[Bot/Crawler]"
if Instr(TheInfo,UCase("grub"))>0 then GetBrType = "Grub"
if Instr(TheInfo,UCase("googlebot"))>0 then GetBrType = "GoogleBot"
if Instr(TheInfo,UCase("msnbot"))>0 then GetBrType = "MSN Bot"
if Instr(TheInfo,UCase("slurp"))>0 then GetBrType = "Yahoo! Slurp"
GetBrType = StrType & GetBrType
end if
if Instr(TheInfo,UCase("applewebkit"))>0 then
StrType = "[AppleWebKit]"
GetBrType = ""
if Instr(TheInfo,UCase("omniweb"))>0 then GetBrType = "OmniWeb"
if Instr(TheInfo,UCase("safari"))>0 then GetBrType = "Safari"
GetBrType = StrType & GetBrType
end if
if Instr(TheInfo,UCase("msie"))>0 then
StrType = "[MSIE"
Tmp1 = mid(TheInfo,(Instr(TheInfo,UCase("MSIE"))+4),6)
Tmp1 = left(Tmp1,Instr(Tmp1,";")-1)
StrType = StrType & Tmp1 & "]"
GetBrType = "Internet Explorer"
GetBrType = StrType & GetBrType
end if
if Instr(TheInfo,UCase("msn"))>0 then GetBrType = "MSN"
if Instr(TheInfo,UCase("aol"))>0 then GetBrType = "AOL"
if Instr(TheInfo,UCase("webtv"))>0 then GetBrType = "WebTV"
if Instr(TheInfo,UCase("myie2"))>0 then GetBrType = "MyIE2"
if Instr(TheInfo,UCase("maxthon"))>0 then GetBrType = "Maxthon(傲游浏览器)"
if Instr(TheInfo,UCase("gosurf"))>0 then GetBrType = "GoSurf(冲浪高手浏览器)"
if Instr(TheInfo,UCase("netcaptor"))>0 then GetBrType = "NetCaptor"
if Instr(TheInfo,UCase("sleipnir"))>0 then GetBrType = "Sleipnir"
if Instr(TheInfo,UCase("avant browser"))>0 then GetBrType = "AvantBrowser"
if Instr(TheInfo,UCase("greenbrowser"))>0 then GetBrType = "GreenBrowser"
if Instr(TheInfo,UCase("slimbrowser"))>0 then GetBrType = "SlimBrowser"
if Instr(TheInfo,UCase("360SE"))>0 then GetBrType = GetBrType & "-360SE(360安全浏览器)"
if Instr(TheInfo,UCase("QQDownload"))>0 then GetBrType = GetBrType & "-QQDownload(QQ下载器)"
if Instr(TheInfo,UCase("TheWorld"))>0 then GetBrType = GetBrType & "-TheWorld(世界之窗浏览器)"
if Instr(TheInfo,UCase("icafe8"))>0 then GetBrType = GetBrType & "-icafe8(网维大师网吧管理插件)"
if Instr(TheInfo,UCase("TencentTraveler"))>0 then GetBrType = GetBrType & "-TencentTraveler(腾讯TT浏览器)"
if Instr(TheInfo,UCase("baiduie8"))>0 then GetBrType = GetBrType & "-baiduie8(百度IE8.0)"
if Instr(TheInfo,UCase("iCafeMedia"))>0 then GetBrType = GetBrType & "-iCafeMedia(网吧网媒趋势插件)"
if Instr(TheInfo,UCase("DigExt"))>0 then GetBrType = GetBrType & "-DigExt(IE5允许脱机阅读模式特殊标记)"
if Instr(TheInfo,UCase("baiduds"))>0 then GetBrType = GetBrType & "-baiduds(百度硬盘搜索)"
if Instr(TheInfo,UCase("CNCDialer"))>0 then GetBrType = GetBrType & "-CNCDialer(数控拨号)"
if Instr(TheInfo,UCase("NOKIAN85"))>0 then GetBrType = GetBrType & "-NOKIAN85(诺基亚手机)"
if Instr(TheInfo,UCase("SPV_C600"))>0 then GetBrType = GetBrType & "-SPV_C600(多普达C600)"
if Instr(TheInfo,UCase("Smartphone"))>0 then GetBrType = GetBrType & "-Smartphone(Windows Mobile for Smartphone Edition 操作系统的智能手机)"
End Function
Function CheckDir(FolderPath)
dim fso
folderpath=Server.MapPath(".")&"\"&folderpath
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolderPath) then
'存在
CheckDir = True
Else
'不存在
CheckDir = False
End if
Set fso = nothing
End Function
Function CheckFile(FilePath) '检查某一文件是否存在
Dim fso
Filepath=Server.MapPath(FilePath)
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FilePath) then
'存在
CheckFile = True
Else
'不存在
CheckFile = False
End if
Set fso = nothing
End Function
function CreateFolder(strFolder)
strTestFolder = Server.Mappath(strFolder)
set objFSO = server.CreateObject("scripting.filesystemobject")
if objFSO.FolderExists(strTestFolder) Then
CreateFolder=false
else
objFSO.createfolder(strTestFolder)
CreateFolder=true
end if
set objFSO=nothing
end function
'force强制覆盖
Public Function CopyAFile(SourceFile, DestinationFile,force)
'If CheckFile(SourceFile) = false or force=true Then
set objFSO = server.CreateObject("scripting.filesystemobject")
objFSO.CopyFile SourceFile,DestinationFile
CopyAFile = 1
'Else
' CopyAFile = -1
'End if
End Function
Sub WriteToTextFile (FileUrl,Str,cs)
set stm=server.CreateObject("adodb.stream")
stm.Type=2 '以本模式读取
stm.mode=3
stm.charset=cs
stm.open
stm.WriteText str
stm.SaveToFile server.MapPath(FileUrl),2
stm.flush
stm.Close
set stm=nothing
End Sub
' 格式化时间(显示)
' 参数：n_Flag
' 1:"yyyy-mm-dd hh:mm:ss"
' 2:"yyyy-mm-dd"
' 3:"hh:mm:ss"
' 4:"yyyy年mm月dd日"
' 5:"yyyymmdd"
' 6:"yymmddhhmmss"
Function Format_Time(s_Time, n_Flag)
Dim y, m, d, h, mi, s
Format_Time = ""
If IsDate(s_Time) = False Then Exit Function
y = cstr(year(s_Time))
m = cstr(month(s_Time))
If len(m) = 1 Then m = "0" & m
d = cstr(day(s_Time))
If len(d) = 1 Then d = "0" & d
h = cstr(hour(s_Time))
If len(h) = 1 Then h = "0" & h
mi = cstr(minute(s_Time))
If len(mi) = 1 Then mi = "0" & mi
s = cstr(second(s_Time))
If len(s) = 1 Then s = "0" & s
Select Case n_Flag
Case 1
' yyyy-mm-dd hh:mm:ss
Format_Time = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case 2
' yyyy-mm-dd
Format_Time = y & "-" & m & "-" & d
Case 3
' hh:mm:ss
Format_Time = h & ":" & mi & ":" & s
Case 4
' yyyy年mm月dd日
Format_Time = y & "年" & m & "月" & d & "日"
Case 5
' yyyymmdd
Format_Time = y & m & d
Case 6
' yymmddhhmmss
Format_Time = y & m & d & h & mi & s
End Select
End Function
Function GetJSONValue(s0, nam)
Dim p1 'As Long
Dim p2 'As Long
Dim c 'As String
If Len(s0) < 3 Then Exit Function
p1 = InStr(s0, nam) + Len(nam) + 2
If p1 > 3 Then
p2 = InStr(p1, s0, ",") - 1
If p2 = -1 Then p2 = InStr(p1, s0, "}") - 1
If p2 > -1 Then
c = Mid(s0, p1 + 1, p2 - p1)
c = Replace(c, """", "")
c = Replace(c, "'", "")
c = Replace(c, "\", "")
GetJSONValue = c
End If
End If
End Function
function GetUpdateFileName()
filepath=Request("f")' http://127.0.0.1/index.html
'response.write filepath: response.end
p1=instr(filepath,"//")
if p1>0 then
p2=instr(p1+3,filepath,"/")
if p2>0 then
p3=instr(p1+2,filepath,"?")
if p3>0 then
filename=mid(filepath,p2+1,p3-p2-1)
else
filename=mid(filepath,p2+1,200)
end if
end if
end if
filename=replace(filename,"#","")
GetUpdateFileName=filename
end function
Function getNewestFile(path)
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(path)
dim newestdatetime,newestFile
Set fc = f.Files
For Each f1 in fc
if f1.DateLastModified >newestdatetime then
newestdatetime=f1.DateLastModified
set newestFile=f1
end if
next
Set fso=nothing
if newestFile<>"" then
getNewestFile=newestFile.Path
end if
End Function
function deletefile(filename)
if filename<>"" then
set fso=server.CreateObject("scripting.filesystemobject")
if fso.FileExists(filename) then
fso.DeleteFile filename
deletefile=true
else
'Response.Write ""
deletefile=false
end if
end if
end function
'上传=======================
function updateAction()
dim inputname,immediate,attachdir,dirtype,maxattachsize,upext,msgtype
inputname="filedata"'表单文件域name
attachdir="upload"'上传文件保存路径，结尾不要带/
dirtype=1'1:按天存入目录 2:按月存入目录 3:按扩展名存目录 建议使用按天存
maxattachsize=2097152'最大上传大小，默认是2M
upext="txt,rar,zip,jpg,jpeg,gif,png,swf,wmv,avi,wma,mp3,mid"'上传扩展名
msgtype=2'返回上传参数的格式：1，只返回url，2，返回参数数组
immediate=Request.QueryString("immediate")'立即上传模式，仅为演示用
dim err,msg,upfile
err = ""
msg = "''"
set upfile=new upfile_class
upfile.AllowExt=replace(upext,",",";")+";"
upfile.GetData(maxattachsize)
if upfile.isErr then
select case upfile.isErr
case 1
err="无数据提交"
case 2
err="文件大小超过 "+cstr(maxattachsize)+"字节"
case else
err=upfile.ErrMessage
end select
else
dim attach_dir,attach_subdir,filename,extension,target,tmpfile
extension=upfile.file(inputname).FileExt
select case dirtype
case 1
attach_subdir="day_"+DateFormat(now,"yymmdd")
case 2
attach_subdir="month_"+DateFormat(now,"yymm")
case 3
attach_subdir="ext_"+extension
end select
attach_dir=attachdir+"/"+attach_subdir+"/"
'建文件夹
CreateFolder attach_dir
tmpfile=upfile.AutoSave(inputname,Server.mappath(attach_dir)+"\")
if upfile.isErr then
if upfile.isErr=3 then
err="上传文件扩展名必需为："+upext
else
err=upfile.ErrMessage
end if
else
'生成随机文件名并改名
Randomize timer
filename=DateFormat(now,"yyyymmddhhnnss")+cstr(cint(9999*Rnd))+"."+extension
target=attach_dir+filename
moveFile attach_dir+tmpfile,target
if immediate="1" then target="!"+target
target=jsonString(target)
if msgtype=1 then
msg="'"+target+"'"
else
msg="{'url':'"+target+"','localname':'"+jsonString(upfile.file(inputname).FileName)+"','id':'1'}"
end if
end if
end if
set upfile=nothing
'response.write "{'err':'"+jsonString(err)+"','msg':"+msg+"}"
updateAction=msg
end function
function jsonString(str)
str=replace(str,"\","\\")
str=replace(str,"/","\/")
str=replace(str,"'","\'")
jsonString=str
end function
Function Iif(expression,returntrue,returnfalse)
If expression=true Then
iif=returntrue
Else
iif=returnfalse
End If
End Function
function DateFormat(strDate,fstr)
if isdate(strDate) then
dim i,temp
temp=replace(fstr,"yyyy",DatePart("yyyy",strDate))
temp=replace(temp,"yy",mid(DatePart("yyyy",strDate),3))
temp=replace(temp,"y",DatePart("y",strDate))
temp=replace(temp,"w",DatePart("w",strDate))
temp=replace(temp,"ww",DatePart("ww",strDate))
temp=replace(temp,"q",DatePart("q",strDate))
temp=replace(temp,"mm",iif(len(DatePart("m",strDate))>1,DatePart("m",strDate),"0"&DatePart("m",strDate)))
temp=replace(temp,"dd",iif(len(DatePart("d",strDate))>1,DatePart("d",strDate),"0"&DatePart("d",strDate)))
temp=replace(temp,"hh",iif(len(DatePart("h",strDate))>1,DatePart("h",strDate),"0"&DatePart("h",strDate)))
temp=replace(temp,"nn",iif(len(DatePart("n",strDate))>1,DatePart("n",strDate),"0"&DatePart("n",strDate)))
temp=replace(temp,"ss",iif(len(DatePart("s",strDate))>1,DatePart("s",strDate),"0"&DatePart("s",strDate)))
DateFormat=temp
else
DateFormat=false
end if
end function
Function CreateFolder(FolderPath)
dim lpath,fs,f
lpath=Server.MapPath(FolderPath)
Set fs=Server.CreateObject("Scri"&"pting.File"&"Sys"&"temObject")
If not fs.FolderExists(lpath) then
Set f=fs.CreateFolder(lpath)
CreateFolder=F.Path
end if
Set F=Nothing
Set fs=Nothing
End Function
Function moveFile(oldfile,newfile)
dim fs
Set fs=Server.CreateObject("Scri"&"pting.File"&"Sys"&"temObject")
fs.movefile Server.MapPath(oldfile),Server.MapPath(newfile)
Set fs=Nothing
End Function
'----------------------------------------------------------------------
'转发时请保留此声明信息,这段声明不并会影响你的速度!
'******************* 无惧上传类 V2.2 xheditor特别修改版 ************************************
'作者:梁无惧
'网站:http://www.25cn.com
'电子邮件:yjlrb@21cn.com
'版权声明:版权所有,源代码公开,各种用途均可免费使用,但是修改后必须把修改后的文件
'发送一份给作者.并且保留作者此版权信息
'**********************************************************************
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'文件上传类
Class UpFile_Class
Dim Form,File
Dim AllowExt_ '允许上传类型(白名单)
Dim NoAllowExt_ '不允许上传类型(黑名单)
Dim IsDebug_ '是否显示出错信息
Private oUpFileStream '上传的数据流
Private isErr_ '错误的代码,0或true表示无错
Private ErrMessage_ '错误的字符串信息
Private isGetData_ '指示是否已执行过GETDATA过程
'------------------------------------------------------------------
'类的属性
Public Property Get Version
Version="无惧上传类 Version V2.0"
End Property
Public Property Get isErr '错误的代码,0或true表示无错
isErr=isErr_
End Property
Public Property Get ErrMessage '错误的字符串信息
ErrMessage=ErrMessage_
End Property
Public Property Get AllowExt '允许上传类型(白名单)
AllowExt=AllowExt_
End Property
Public Property Let AllowExt(Value) '允许上传类型(白名单)
AllowExt_=LCase(Value)
End Property
Public Property Get NoAllowExt '不允许上传类型(黑名单)
NoAllowExt=NoAllowExt_
End Property
Public Property Let NoAllowExt(Value) '不允许上传类型(黑名单)
NoAllowExt_=LCase(Value)
End Property
Public Property Let IsDebug(Value) '是否设置为调试模式
IsDebug_=Value
End Property
'----------------------------------------------------------------
'类实现代码
'初始化类
Private Sub Class_Initialize
isErr_ = 0
NoAllowExt="" '黑名单,可以在这里预设不可上传的文件类型,以文件的后缀名来判断,不分大小写,每个每缀名用;号分开,如果黑名单为空,则判断白名单
NoAllowExt=LCase(NoAllowExt)
AllowExt="" '白名单,可以在这里预设可上传的文件类型,以文件的后缀名来判断,不分大小写,每个后缀名用;号分开
AllowExt=LCase(AllowExt)
isGetData_=false
End Sub
'类结束
Private Sub Class_Terminate
on error Resume Next
'清除变量及对像
Form.RemoveAll
Set Form = Nothing
File.RemoveAll
Set File = Nothing
oUpFileStream.Close
Set oUpFileStream = Nothing
if Err.number<>0 then OutErr("清除类时发生错误!")
End Sub
'分析上传的数据
Public Sub GetData (MaxSize)
'定义变量
on error Resume Next
if isGetData_=false then
Dim RequestBinData,sSpace,bCrLf,sInfo,iInfoStart,iInfoEnd,tStream,iStart,oFileInfo
Dim sFormValue,sFileName
Dim iFindStart,iFindEnd
Dim iFormStart,iFormEnd,sFormName
'代码开始
If Request.TotalBytes < 1 Then '如果没有数据上传
isErr_ = 1
ErrMessage_="没有数据上传,这是因为直接提交网址所产生的错误!"
OutErr("没有数据上传,这是因为直接提交网址所产生的错误!!")
Exit Sub
End If
If MaxSize > 0 Then '如果限制大小
If Request.TotalBytes > MaxSize Then
isErr_ = 2 '如果上传的数据超出限制大小
ErrMessage_="上传的数据超出限制大小!"
OutErr("上传的数据超出限制大小!")
Exit Sub
End If
End If
Set Form = Server.CreateObject ("Scripting.Dictionary")
Form.CompareMode = 1
Set File = Server.CreateObject ("Scripting.Dictionary")
File.CompareMode = 1
Set tStream = Server.CreateObject ("ADODB.Stream")
Set oUpFileStream = Server.CreateObject ("ADODB.Stream")
if Err.number<>0 then OutErr("创建流对象(ADODB.STREAM)时出错,可能系统不支持或没有开通该组件")
oUpFileStream.Type = 1
oUpFileStream.Mode = 3
oUpFileStream.Open
oUpFileStream.Write Request.BinaryRead (Request.TotalBytes)
oUpFileStream.Position = 0
RequestBinData = oUpFileStream.Read
Dim sHtml5FileInfo
sHtml5FileInfo=Request.ServerVariables("HTTP_CONTENT_DISPOSITION")
If sHtml5FileInfo<>"" Then'针对Html5上传特别修正
iFindStart = InStr (1,sHtml5FileInfo,"name=""",1)+6
iFindEnd = InStr (iFindStart,sHtml5FileInfo,"""",1)
sFormName=Trim(Mid(sHtml5FileInfo,iFindStart,iFindEnd-iFindStart))
iFindStart = InStr (iFindStart,sHtml5FileInfo,"filename=""",1)+10
iFindEnd = InStr (iFindStart,sHtml5FileInfo,"""",1)
sFileName = Trim(Mid(sHtml5FileInfo,iFindStart,iFindEnd-iFindStart))
Set oFileInfo = new FileInfo_Class
oFileInfo.FileName = URLDecode(GetFileName(sFileName))
oFileInfo.FilePath = GetFilePath(sFileName)
oFileInfo.FileExt = GetFileExt(sFileName)
oFileInfo.FileStart = 0
oFileInfo.FileSize = Request.TotalBytes
oFileInfo.FormName = sFormName
file.add sFormName,oFileInfo
Else
iFormEnd = oUpFileStream.Size
bCrLf = ChrB (13) & ChrB (10)
'取得每个项目之间的分隔符
sSpace = MidB (RequestBinData,1, InStrB (1,RequestBinData,bCrLf)-1)
iStart = LenB(sSpace)
iFormStart = iStart+2
'分解项目
Do
iInfoEnd = InStrB (iFormStart,RequestBinData,bCrLf & bCrLf)+3
tStream.Type = 1
tStream.Mode = 3
tStream.Open
oUpFileStream.Position = iFormStart
oUpFileStream.CopyTo tStream,iInfoEnd-iFormStart
tStream.Position = 0
tStream.Type = 2
tStream.CharSet = "utf-8"
sInfo = tStream.ReadText
'取得表单项目名称
iFormStart = InStrB (iInfoEnd,RequestBinData,sSpace)-1
iFindStart = InStr (22,sInfo,"name=""",1)+6
iFindEnd = InStr (iFindStart,sInfo,"""",1)
sFormName = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
'如果是文件
If InStr (45,sInfo,"filename=""",1) > 0 Then
Set oFileInfo = new FileInfo_Class
'取得文件属性
iFindStart = InStr (iFindEnd,sInfo,"filename=""",1)+10
iFindEnd = InStr (iFindStart,sInfo,""""&vbCrLf,1)
sFileName = Trim(Mid(sinfo,iFindStart,iFindEnd-iFindStart))
oFileInfo.FileName = GetFileName(sFileName)
oFileInfo.FilePath = GetFilePath(sFileName)
oFileInfo.FileExt = GetFileExt(sFileName)
iFindStart = InStr (iFindEnd,sInfo,"Content-Type: ",1)+14
iFindEnd = InStr (iFindStart,sInfo,vbCr)
oFileInfo.FileMIME = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
oFileInfo.FileStart = iInfoEnd
oFileInfo.FileSize = iFormStart -iInfoEnd -2
oFileInfo.FormName = sFormName
file.add sFormName,oFileInfo
else
'如果是表单项目
tStream.Close
tStream.Type = 1
tStream.Mode = 3
tStream.Open
oUpFileStream.Position = iInfoEnd
oUpFileStream.CopyTo tStream,iFormStart-iInfoEnd-2
tStream.Position = 0
tStream.Type = 2
tStream.CharSet = "utf-8"
sFormValue = tStream.ReadText
If Form.Exists (sFormName) Then
Form (sFormName) = Form (sFormName) & ", " & sFormValue
else
Form.Add sFormName,sFormValue
End If
End If
tStream.Close
iFormStart = iFormStart+iStart+2
'如果到文件尾了就退出
Loop Until (iFormStart+2) >= iFormEnd
if Err.number<>0 then OutErr("分解上传数据时发生错误,可能客户端的上传数据不正确或不符合上传数据规则")
End if
RequestBinData = ""
Set tStream = Nothing
isGetData_=true
end if
End Sub
'保存到文件,自动覆盖已存在的同名文件
Public Function SaveToFile(Item,Path)
SaveToFile=SaveToFileEx(Item,Path,True)
End Function
'保存到文件,自动设置文件名
Public Function AutoSave(Item,Path)
AutoSave=SaveToFileEx(Item,Path,false)
End Function
'保存到文件,OVER为真时,自动覆盖已存在的同名文件,否则自动把文件改名保存
Private Function SaveToFileEx(Item,Path,Over)
On Error Resume Next
Dim FileExt
if file.Exists(Item) then
Dim oFileStream
Dim tmpPath
isErr_=0
Set oFileStream = CreateObject ("ADODB.Stream")
oFileStream.Type = 1
oFileStream.Mode = 3
oFileStream.Open
oUpFileStream.Position = File(Item).FileStart
oUpFileStream.CopyTo oFileStream,File(Item).FileSize
tmpPath=Split(Path,".")(0)
FileExt=GetFileExt(Path)
if Over then
if isAllowExt(FileExt) then
oFileStream.SaveToFile tmpPath & "." & FileExt,2
if Err.number<>0 then OutErr("保存文件时出错,请检查路径,是否存在该上传目录!该文件保存路径为" & tmpPath & "." & FileExt)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
OutErr("该后缀名的文件不允许上传")
End if
Else
Path=GetFilePath(Path)
dim fori
fori=1
if isAllowExt(File(Item).FileExt) then
do
fori=fori+1
Err.Clear()
tmpPath=Path&GetNewFileName()&"."&File(Item).FileExt
oFileStream.SaveToFile tmpPath
loop Until ((Err.number=0) or (fori>50))
if Err.number<>0 then OutErr("自动保存文件出错,已经测试50次不同的文件名来保存,请检查目录是否存在!该文件最后一次保存时全路径为"&Path&GetNewFileName()&"."&File(Item).FileExt)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
OutErr("该后缀名的文件不允许上传")
End if
End if
oFileStream.Close
Set oFileStream = Nothing
else
ErrMessage_="不存在该对象(如该文件没有上传,文件为空)!"
OutErr("不存在该对象(如该文件没有上传,文件为空)")
end if
if isErr_=3 then SaveToFileEx="" else SaveToFileEx=GetFileName(tmpPath)
End Function
'取得文件数据
Public Function FileData(Item)
isErr_=0
if file.Exists(Item) then
if isAllowExt(File(Item).FileExt) then
oUpFileStream.Position = File(Item).FileStart
FileData = oUpFileStream.Read (File(Item).FileSize)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传"
OutErr("该后缀名的文件不允许上传")
FileData=""
End if
else
ErrMessage_="不存在该对象(如该文件没有上传,文件为空)!"
OutErr("不存在该对象(如该文件没有上传,文件为空)")
end if
End Function
'取得文件路径
Public function GetFilePath(FullPath)
If FullPath <> "" Then
GetFilePath = Left(FullPath,InStrRev(FullPath, "\"))
Else
GetFilePath = ""
End If
End function
'取得文件名
Public Function GetFileName(FullPath)
If FullPath <> "" Then
GetFileName = mid(FullPath,InStrRev(FullPath, "\")+1)
Else
GetFileName = ""
End If
End function
'取得文件的后缀名
Public Function GetFileExt(FullPath)
If FullPath <> "" Then
GetFileExt = LCase(Mid(FullPath,InStrRev(FullPath, ".")+1))
Else
GetFileExt = ""
End If
End function
'取得一个不重复的序号
Public Function GetNewFileName()
dim ranNum
dim dtNow
dtNow=Now()
randomize
ranNum=int(90000*rnd)+10000
'以下这段由webboy提供
GetNewFileName=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
Public Function isAllowExt(Ext)
if NoAllowExt="" then
isAllowExt=cbool(InStr(1,";"&AllowExt&";",LCase(";"&Ext&";")))
else
isAllowExt=not CBool(InStr(1,";"&NoAllowExt&";",LCase(";"&Ext&";")))
end if
End Function
End Class
Public Sub OutErr(ErrMsg)
if IsDebug_=true then
Response.Write ErrMsg
Response.End
End if
End Sub
'----------------------------------------------------------------------------------------------------
'文件属性类
Class FileInfo_Class
Dim FormName,FileName,FilePath,FileSize,FileMIME,FileStart,FileExt
End Class
function URLDecode(strIn)
URLDecode = ""
Dim sl: sl = 1
Dim tl: tl = 1
Dim key: key = "%"
Dim kl: kl = Len(key)
sl = InStr(sl, strIn, key, 1)
Do While sl>0
If (tl=1 And sl<>1) Or tl