asp 自用 公用函数

<%
'////////////////
'////////常用函数
'///////////////
'读取记事本函数
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
if instr(filename,":\")>0 or instr(filename,"\\")>0 then '//如果是绝对路径
Set  objCountFile = objFSO.OpenTextFile(filename,1,True)
else'//相对路径
Set  objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
end if
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
end function
'写入到记事本函数
function FSOFileWrite(filename, content)
Set fso = Server.CreateObject("scripting.FileSystemObject") '创建FSO对象
'if isServePath=true then Set fileObj = fso.opentextfile(Server.MapPath(filename),2,true) '使用FSO创建文件写入对象
Set fileObj = fso.opentextfile(filename,2,true) '使用FSO创建文件写入对象
fileObj.write content
fileObj.close
'response.Write("save succuse")
Set fileObj = nothing
Set fso = nothing
end function
'字符串截取
function ZqStr(all,sta,fin)
dim arr
dim i
arr=split(all,sta)
for i=1 to ubound(arr)
if instr(arr(i),fin)>0 then 
ZqStr=split(arr(i),fin)(0)
end if
next
end function
'ASP判断文件是否存在以及删除文件实例代码
public function isFileExists(filename)
if instr(filename,":\")>0 or instr(filename,"\\")>0 then '//如果是绝对路径
filename=filename
else'//相对路径
filename=server.MapPath(filename)
end if
Set fs=Server.CreateObject("Scripting.FileSystemObject")
If fs.FileExists(filename) Then   '判断文件是否存在
isFileExists=true
'fs.DeleteFile filename,true  '如果文件存在，则删除文件
else
isFileExists=false
end if
Set fs=Nothing
end function


 
%>


<%'================================================ 
'函数名：URLDecode 
'作 用：URL解码 
'================================================ 
Function URLDecode(ByVal urlcode) 
Dim start,final,length,char,i,butf8,pass 
Dim leftstr,rightstr,finalstr 
Dim b0,b1,bx,blength,position,u,utf8 
On Error Resume Next 


b0 = Array(192,224,240,248,252,254) 
urlcode = Replace(urlcode,"+"," ") 
pass = 0 
utf8 = -1 


length = Len(urlcode) : start = InStr(urlcode,"%") : final = InStrRev(urlcode,"%") 
If start = 0 Or length < 3 Then URLDecode = urlcode : Exit Function 
leftstr = Left(urlcode,start - 1) : rightstr = Right(urlcode,length - 2 - final) 


For i = start To final 
char = Mid(urlcode,i,1) 
If char = "%" Then 
bx = URLDecode_Hex(Mid(urlcode,i + 1,2)) 
If bx > 31 And bx < 128 Then 
i = i + 2 
finalstr = finalstr & ChrW(bx) 
ElseIf bx > 127 Then 
i = i + 2 
If utf8 < 0 Then 
butf8 = 1 : blength = -1 : b1 = bx 
For position = 4 To 0 Step -1 
If b1 >= b0(position) And b1 < b0(position + 1) Then 
blength = position 
Exit For 
End If 
Next 
If blength > -1 Then 
For position = 0 To blength 
b1 = URLDecode_Hex(Mid(urlcode,i + position * 3 + 2,2)) 
If b1 < 128 Or b1 > 191 Then butf8 = 0 : Exit For 
Next 
Else 
butf8 = 0 
End If 
If butf8 = 1 And blength = 0 Then butf8 = -2 
If butf8 > -1 And utf8 = -2 Then i = start - 1 : finalstr = "" : pass = 1 
utf8 = butf8 
End If 
If pass = 0 Then 
If utf8 = 1 Then 
b1 = bx : u = 0 : blength = -1 
For position = 4 To 0 Step -1 
If b1 >= b0(position) And b1 < b0(position + 1) Then 
blength = position 
b1 = (b1 xOr b0(position)) * 64 ^ (position + 1) 
Exit For 
End If 
Next 
If blength > -1 Then 
For position = 0 To blength 
bx = URLDecode_Hex(Mid(urlcode,i + 2,2)) : i = i + 3 
If bx < 128 Or bx > 191 Then u = 0 : Exit For 
u = u + (bx And 63) * 64 ^ (blength - position) 
Next 
If u > 0 Then finalstr = finalstr & ChrW(b1 + u) 
End If 
Else 
b1 = bx * &h100 : u = 0 
bx = URLDecode_Hex(Mid(urlcode,i + 2,2)) 
If bx > 0 Then 
u = b1 + bx 
i = i + 3 
Else 
If Left(urlcode,1) = "%" Then 
u = b1 + Asc(Mid(urlcode,i + 3,1)) 
i = i + 2 
Else 
u = b1 + Asc(Mid(urlcode,i + 1,1)) 
i = i + 1 
End If 
End If 
finalstr = finalstr & Chr(u) 
End If 
Else 
pass = 0 
End If 
End If 
Else 
finalstr = finalstr & char 
End If 
Next 
URLDecode = leftstr & finalstr & rightstr 
End Function 


Function URLDecode_Hex(ByVal h) 
On Error Resume Next 
h = "&h" & Trim(h) : URLDecode_Hex = -1 
If Len(h) <> 4 Then Exit Function 
If isNumeric(h) Then URLDecode_Hex = cInt(h) 
End Function%>


<% 


function gethttppage(url) 
on error  resume next
If err then
err.clear
End If
dim adxmlhttp 
set adxmlhttp = Server.createobject("microsoft.xmlhttp") 
adxmlhttp.open "get",url,false 
adxmlhttp.send() 
if adxmlhttp.readystate <> 4 then exit function 
gethttppage = Bytes2bStr(adxmlhttp.responsebody) 
set adxmlhttp = nothing 
End function 


function Bytes2bStr(vin) 
Dim BytesStream,StringReturn 
Set BytesStream = Server.CreateObject("adodb.stream") 
BytesStream.Type = 2 
BytesStream.Open 
BytesStream.WriteText vin 
BytesStream.Position = 0 
BytesStream.Charset = "GB2312" 
BytesStream.Position = 2 
StringReturn =BytesStream.ReadText 
BytesStream.close 
Set BytesStream = Nothing 
Bytes2bStr = StringReturn 
End function 


%>