📄 nntup.asp
字号:
<%
Function GetmyWebData(strUrl)
On Error Resume Next
dim curlpath
dim Retrieval
Set Retrieval = Server.CreateObject("Microso"&"ft.XM"&"LHTTP")
With Retrieval
.Open "Get",strUrl, False, "", ""
.Send
GetmyWebData =.ResponseBody
'Response.Write .ResponseBody
End With
GetmyWebData=BytesToBstr(GetmyWebData,"GB2312")
Set Retrieval = Nothing
End Function
Function BytesToBstr(strBody,CodeBase)
dim objStream
set objStream = Server.CreateObject("Ado"&"db.Str"&"eam")
objStream.Type = 1
objStream.Mode =3
objStream.Open
objStream.Write strBody
objStream.Position = 0
objStream.Type = 2
objStream.Charset = CodeBase
BytesToBstr = objStream.ReadText
objStream.Close
set objStream = nothing
End Function
Function ASCII2Unicode(str)
dim strLen,res,I
strLen=LenB(str)
I=1
While I < strLen+1
If I<>strLen And AscB(MidB(str,I,1))>127 Then
res=res&Chr(AscB(MidB(str,I,1))*256+AscB(MidB(str,I+1,1)))
I=I+1
Else
res=res&ChrW(AscB(MidB(str,I,1)))
End If
I=I+1
Wend
ASCII2Unicode=res
End Function
Class BoxInfoImg
'传输类的使用方法
'图象上传和上传信息获取CLASS
'用法:
'dim imgUp
'set imgUp=new BoxInfoImg
'属性:
'imgUp.width '宽
'imgUp.height '高
'imgUp.imgSize '大小
'imgUp.imgType '类型
'imgUp.imgName '文件名
'imgUp.imgName '图像文件名:"&
'imgUp.filename '文件名"&
'imgUp.extName '扩展名"
'imgUp.DiskPath '保存位置"
'imgUp.XuPath '虚拟路径"
'imgUp.NewUrl '保存后url"
'imgUp.SaveMode '保存后url"
'方法:
'imgUp.saveImg(fullpath) '保存图像文件
dim ADOS
dim width,height,imgSize,imgType,imgName,fileName
dim preName,extName
dim SavePath,SaveName,SaveMode
dim DiskPath,XuPath,NewUrl
dim textStr
dim i
Private Sub Class_Initialize
set ADOS=Server.CreateObject("Ado"&"db.Str"&"eam")
ADOS.Type=1
ADOS.Mode=3
ADOS.Open
getImageSize
End Sub
Private Sub Class_Terminate
ADOS.close
set ADOS=nothing
End Sub
Public Function getImageSize()
dim ret(3),bFlag,fdata,fsize
fdata=GetWebData(GetStrUrl) '取得XmlHttp数据
fsize=clng(lenb(fdata)) '取得数据尺寸
if fsize=0 then
exit function
'R_Write "无有效数据保存",0
end if
ADOS.Write fdata
ADOS.Position=0
SaveName=iSaveName
SavePath=iSavePath
SaveMode=iSaveMode
'写文本对象读取图像长宽和类型
ADOS.Position=0 '重置数据开始位置
bFlag=ADOS.read(3)
if isNull(bFlag) then
width=0
height=0
imgSize=0
imgType="unknow"
ret(0)=imgType:ret(1)=width:ret(2)=height:ret(3)=""
getimagesize=ret
exit function
end if
'取文件类型和长宽
select case hex(binVal(bFlag))
case "4E5089":
ADOS.read(15)
ret(0)="png"
ret(1)=BinVal2(ADOS.read(2))
ADOS.read(2)
ret(2)=BinVal2(ADOS.read(2))
case "464947":
ADOS.read(3)
ret(0)="gif"
ret(1)=BinVal(ADOS.read(2))
ret(2)=BinVal(ADOS.read(2))
case "FFD8FF":
dim p1
do
do: p1=binVal(ADOS.Read(1)): loop while p1=255 and not ADOS.EOS
if p1>191 and p1<196 then exit do else ADOS.read(binval2(ADOS.Read(2))-2)
do:p1=binVal(ADOS.Read(1)):loop while p1<255 and not ADOS.EOS
loop while true
ADOS.Read(3)
ret(0)="jpg"
ret(2)=binval2(ADOS.Read(2))
ret(1)=binval2(ADOS.Read(2))
case else:
if left(Bin2Str(bFlag),2)="BM" then
ADOS.Read(15)
ret(0)="bmp"
ret(1)=binval(ADOS.Read(4))
ret(2)=binval(ADOS.Read(4))
else
ret(0)=""
end if
end select
'
dim tempStr
dim nameStr
dim defaultName
dim ln
tempStr=split(GetStrUrl,"/")
nameStr=tempStr(ubound(tempStr))
if nameStr="" then
'R_Write "错误的URL,请输入可访问的URL",0
exit function
end if
fileName=split(nameStr,"?")(0)
ln=inStrRev(fileName,".")
if ln>0 then
preName=left(fileName,inStrRev(fileName,".")-1)
else
preName=fileName
end if
''R_Write fileName,1
''R_Write inStrRev(fileName,"."),1
''R_Write fileName,0
extName=right(fileName,len(fileName)-inStrRev(fileName,"."))
Select case ret(0)
case "png","jpg","bmp","gif","****"
width=ret(1)
height=ret(2)
imgSize=fsize
imgType=ret(0)
imgName=preName&"."&ret(0)
case else
width=0
height=0
imgSize=fsize
imgName="unknow"
imgType=".unknow"
end select
if SaveMode="1" then
defaultName=imgName
if SaveName="" then
SaveName=defaultName
else
if lcase(right(SaveName,4))<>"."&imgType then
SaveName=SaveName&"."&imgType
end if
end if
else
defaultName=filename
end if
if SaveName="" then SaveName=defaultName
SavePath=replace(SavePath,"//","/")
if right(SavePath,1)<>"/" then SavePath=SavePath&"/"
if SavePath="" then SavePath="./"
DiskPath=server.mappath(SavePath&SaveName)
XuPath=replace(replace(DiskPath,server.mappath("/"),""),"\","/")
NewUrl="http://"&Request.ServerVariables("SERVER_NAME")&XuPath
getimagesize=ret
End Function
Public function SaveImg(FullPath)
SaveImg=false
if SaveMode="1" then
if trim(fullpath)="" or _
width=0 or _
height=0 or _
imgSize=0 or _
imgType=".unknow" then exit function end if
end if
ADOS.Position=0
if SaveMode="2" then
ADOS.Type=2
ADOS.Charset ="gb2312"
ADOS.SaveToFile FullPath,2
textStr=ADOS.readtext()
else
ADOS.SaveToFile FullPath,2
end if
SaveImg=true
End function
Private Function Bin2Str(Bin)
Dim I,Str,clow
For I=1 to LenB(Bin)
clow=MidB(Bin,I,1)
if ASCB(clow)<128 then
Str = Str & Chr(ASCB(clow))
else
I=I+1
if I <= LenB(Bin) then Str = Str & Chr(ASCW(MidB(Bin,I,1)&clow))
end if
Next
Bin2Str = Str
End Function
Private Function Num2Str(num,base,lens)
dim ret:ret = ""
while(num>=base)
ret=(num mod base) & ret
num=(num - num mod base)/base
wend
Num2Str = right(string(lens,"0") & num & ret,lens)
End Function
Private Function Str2Num(str,base)
dim ret:ret = 0
for i=1 to len(str)
ret = ret *base + cint(mid(str,i,1))
next
Str2Num=ret
End Function
Private Function BinVal(bin)
dim ret:ret = 0
for i = lenb(bin) to 1 step -1
ret = ret *256 + ascb(midb(bin,i,1))
next
BinVal=ret
End Function
Private Function BinVal2(bin)
dim ret:ret = 0
for i = 1 to lenb(bin)
ret = ret *256 + ascb(midb(bin,i,1))
next
BinVal2=ret
End Function
Private Function GetWebData(byval StrUrl)
if StrUrl="" then
'R_Write "无效",1
exit function
end if
dim tempStr
tempStr=split(GetStrUrl,"/")
if tempStr(ubound(tempStr))="" or inStr(StrUrl,"/")=0 then
'R_Write "未指定有效的URL",0
exit function
end if
dim Retrieval
Set Retrieval = Server.CreateObject("Microso"&"ft.XM"&"LHTTP")
With Retrieval
.Open "Get", StrUrl, False, "", ""
.Send
GetWebData =.ResponseBody
End With
Set Retrieval = Nothing
End Function
End Class
SUB saveUpload(GetUrl,SavePath,SaveName,mode)
dim chkInfo
'Response.Write geturl
if GetUrl="" then
'call tform()
'R_Write "<br>传输文件栏没有填写!",0
end if
set imgUp=new BoxInfoImg
if mode="1" and imgUp.imgName="unknow" then
call tform()
set imgUp=nothing
'R_Write "<br>传输文件栏没有填写有效的图像URL!",0
end if
chkInfo=""
dim i,testStr,showStr
'限定格式
select case imgUp.imgType
case "png","jpg","bmp","gif"
if imgUp.width=0 or imgUp.height=0 or imgUp.imgSize=0 then
chkInfo="<li>"+"传输图像数据不存在,请确定你的URL是否正确"
end if
case else
chkInfo="<li>无效的传输格式,允许图像数据格式为 ""png"",""jpg"",""bmp"",""gif""</li>"
end select
''R_Write SavePath,1
''R_Write mode,1
''R_Write imgUp.imgName,1
''R_Write imgUp.filename,1
''R_Write "SaveName="&SaveName,1
if mode="1" and chkInfo<>"" then '检查上传图像数据合格后,则保存之
call tform()
'R_Write chkInfo,0
else
Server.ScriptTimeOut=5000
imgUp.saveImg imgUp.DiskPath
end if
'-------------
'R_Write "<b>===处理结果部分资料===</b><br>",1
'R_Write " 宽:"&imgUp.width&" pix",1
'R_Write " 高:"&imgUp.height&" pix",1
'R_Write " 大小:"&formatnumber(imgUp.imgSize/1024,2,-1)&" KB",1
'R_Write " 格式:"&imgUp.imgType,1
'R_Write "图像文件名:"&imgUp.imgName,1
'R_Write "文件名:"&imgUp.filename,1
'R_Write "扩展名:"&imgUp.extName,1
'R_Write "保存位置:"&imgUp.DiskPath,1
'R_Write "虚拟路径:"&imgUp.XuPath,1
'R_Write "保存后url:"&imgUp.NewUrl,1
'call tform()
set imgUp=nothing
'R_Write "------------------------<br>传输完毕",0
End SUB
function DIRNAME(PATH) '读出路径下的文件名,并存在一个数组中第一个元素是路径加文件名,第二个是文件名
set fso=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(path,":\")<>0 then
path=path
else
path=server.MapPath(path)
end if
set myfolder=fso.getfolder(path)
dim di(350,2)
i=0
for each x in myfolder.files
di(i,1)=x
di(i,2)=fso.getfilename(x)
i=i+1
next
DIRNAME=DI
END function
Function Er() '错误处理
If Err.Number = 0 Then
Er = False
Else
Err.Clear
Er = True
End If
End Function
SUB SAVEFILE(FILENAME,DATA) '用于写入二进制的内容
SET ADF=SERVER.CREATEOBJECT("Ado"&"db.Str"&"eam")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
WITH ADF
.Type=1
.Open
.Write Data
.SaveToFile path,2
.Cancel()
.Close()
END WITH
SET ADF=NOTHING
END sub
function Readfile(FileName) '这是一个用于读出二进制文件的函数
set adf=server.CreateObject("Ado"&"db.Str"&"eam")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
with adf
.Type=1
.Open
.LoadFromFile (path)
Readfile=.Read
.Cancel()
.Close()
end with
set adF=nothing
end function
Function TESTFILe(FileName) '这是一个用于检测一个文件是否存在的函数
On Error Resume Next
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
PA=FS.GETFILE(PATH)
set fs=nothing
if er() then
testfile=False
else
testfile=True
end if
end Function
'写文件开始！！！自动升级
Function DB2FILE(RSFILEDB)
FILEZS=1
DO WHILE NOT RSFILEDB.EOF
filePATH=RSFILEDB("boopath")
FILENAME=RSFILEDB("booname")
if right(filepath,1)="\" or right(filepath,1)="/" then
PATHNAME=filePATH&FILENAME
else
PATHNAME=filePATH&"\"&FILENAME
end if
filepath=server.MapPath(filepath)
if not tesfold(filepath) then
' Response.Write "<font color=#ff0000>建立目录："&filepath&"</font><br>"
call createfold(filepath)
end if
if instr(pathname," ")=0 then
'Response.Write "生成文件: "&pathname&"<br>"
CALL SAVEFILE(PATHNAME,RSFILEDB("booneirong"))
filezs=filezs+1
end if
RSFILEDB.MOVENEXT
LOOP
DB2FILE=FILEZS
END Function
function tesfold(foname) '用来检测指定的目录是否存在
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if fs.folderexists(foname) then
tesfold=True
else
tesfold= False
end if
set fs=nothing
end function
sub createfold(foname) '用来建立一个目录
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
fs.createfolder(foname)
set fs=nothing
end sub
function tablist() '用于检测当前连接的数据库有哪些表
dim tabli(100)
Set rstSchema=conn.OpenSchema(20)
lii=0
Do Until rstSchema.EOF
if rstSchema(3)="TABLE" then
tabli(lii)=rstSchema(2)
lii=lii+1
end if
rstSchema.MoveNext
Loop
tablist=tabli
end function
function testab(tabname) '此此函数用于判断是否有指定的表
ON ERROR RESUME NEXT
SQL="SELECT ID FROM ["&TABNAME&"] where id=0"
Set rstes=Server.CreateObject("Ado"&"db.Rec"&"ordSet")
' Response.Write sql&"<BR>"
rstes.Open sql , conna ,1,1
IF COnna.ERRORS.COUNT <>0 THEN
tesTAB=False
else
testab=True
END IF
rstes.close
end function
function datatype() '返回当前打开的数据库的类型
DATYPE="其它"
for tyi=0 to 10
if testab("user1") then
datype="USER"
exit for
else
if testab("menu") then
DATYPE="NEWDATA"
exit for
end if
end if
next
' Response.Write DATYPE&"<BR>"
DATATYPE=DATYPE
end function
sub delfile(FileName) '这是一个用于删除文件的过程,如未指定文件名,将删除该目录下所有文件
On Error Resume Next
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
' Response.Write path
fs.deletefile path,TRUE
set ts=nothing
end sub
sub rd(mName) '这是一个用于删除文件的过程,如未指定文件名,将删除该目录下所有文件
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(filename,":\")<>0 then
path=mName
else
path=server.MapPath(mName)
end if
' Response.Write path&"<br>"
On Error Resume Next
fs.deletefolder path,TRUE
set ts=nothing
end sub
sub SaveText(FileName,Data) '这是一个用于写文本文件的过程
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
set ts=fs.createtextfile(path,true)
ts.writeline(data)
ts.close
set ts=nothing
set fs=nothing
end sub
sub copyfile(FileName1,filename2) '这是一个用于改文件名的函数
On Error Resume Next
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(filename1,":\")<>0 then
path1=filename1
else
path1=server.MapPath(FileName1)
end if
if instr(filename2,":\")<>0 then
path1=filename2
else
path2=server.MapPath(FileName2)
end if
fs.copyfile path1,path2
set ts=nothing
end sub
function ReadText(FileName) '这是一个用于读出文本文件的函数
On Error Resume Next
set adf=server.CreateObject("Ado"&"db.Str"&"eam")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
with adf
' response.write path
.Type=2
.LineSeparator=13
.Open
.LoadFromFile (path)
.Charset="GB2312"
.Position=2
ReadText=.ReadText
.Cancel()
.Close()
end with
set adF=nothing
end function
sub SaveText(FileName,Data) '这是一个用于写文本文件的过程
set fs=createobject("scrip"&"ting.filesys"&"temob"&"ject")
if instr(filename,":\")<>0 then
path=filename
else
path=server.MapPath(FileName)
end if
set ts=fs.createtextfile(path,true)
ts.writeline(data)
ts.close
set ts=nothing
set fs=nothing
end sub
%>
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -