<%
''''===============================================''''
'''' 函数制作说明 ''''
'''' 本函数库作者：马政永，内蒙古阿拉善 ''''
''''作者主页：www.lovemycn.com or als.lovemycn.com ''''
''''作者邮箱：mzymcm@yahoo.com.cn Phone:13947490036''''
'''' ''''
'''' 本函数免费提供使用，但不要去版权信息 ''''
'''' ''''
'''' 本函数库还在丰富中，多谢支持 ''''
''''-----------------------------------------------''''
''''===============================================''''
'''' 函数目录 ''''
''''-----------------------------------------------''''
'''' 函数ID：0001[截字符串] ''''
'''' 函数ID：0002[过滤html] ''''
'''' 函数ID：0003[打开任意数据表并显示表结构及内容]''''
'''' 函数ID：0004[读取两种路径] ''''
'''' 函数ID：0005[测试某个文件存在否] ''''
'''' 函数ID：0006[删除某个文件] ''''
'''' 函数ID：0007[判断目录是否存在] ''''
'''' 函数ID：0008[创建目录] ''''
'''' 函数ID：0009[删除目录] ''''
'''' 函数ID：0010[指定目录的文件列表] ''''
'''' 函数ID：0011[指定目录的目录列表] ''''
'''' 函数ID：0012[创建文本文件] ''''
'''' 函数ID：0013[读取文本文件] ''''
'''' 函数ID：0014[检测ID是否为数字类型] ''''
'''' 函数ID：0015[正则表达式测试] ''''
'''' 函数ID：0016[获得执行程序的名称] ''''
'''' 函数ID：0017[读取用户IP地址信息] ''''
'''' 函数ID：0018[上传文件到指定目录并改文件名称] ''''
'''' 函数ID：0019[过滤HTML脚本] ''''
'''' 函数ID：0020[创建MsAccess数据库] ''''
'''' 函数ID：0021[创建MsSQLServer数据库] ''''

'**************************************************''''
'函数ID：0001[截字符串]
'函数名：SubstZFC
'作 用：截字符串，汉字一个算两个字符，英文算一个字符
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'**************************************************
Public Function SubstZFC(ByVal str, ByVal strlen)
If str = "" Then
SubstZFC = ""
Exit Function
End If
Dim l, t, c, i, strTemp
str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = Len(str)
t = 0
strTemp = str
strlen = CLng(strlen)
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strlen Then
strTemp = Left(str, i)
Exit For
End If
Next
If strTemp <> str Then
strTemp = strTemp & "…"
End If
SubstZFC = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<")
End Function

'**************************************************
'函数ID：0002[过滤html]
'函数名：GlHtml
'作 用：过滤html 元素
'参 数：str ---- 要过滤字符
'返回值：没有html 的字符
'**************************************************
Public Function GlHtml(ByVal str)
If IsNull(str) or Trim(str) = "" Then
GlHtml = ""
Exit Function
End If
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(\<.[^\<]*\>)"
str = re.Replace(str, " ")
re.Pattern = "(\<\/[^\<]*\>)"
str = re.Replace(str, " ")
Set re = Nothing
str = Replace(str, "'", "")
str = Replace(str, Chr(34), "")
GlHtml = str
End Function

'**************************************************
'函数ID：0003[打开任意数据表并显示表结构及内容]
'函数名：OpOtherDB
'作 用：打开任意数据表并显示表结构及内容
'参 数：DBtheStr ---- 要打开表的数据库链接字串
'参 数：Opentdname ---- 要打开表名
'返回值：显示表结构及内容
'**************************************************
Public Function OpOtherDB(ByVal DBtheStr,ByVal Opentdname)
Response.write "" & vbCrlf
Set Opdb_Conn=server.createobject("ADODB.Connection")
Set Opdb_Rs =server.createobject("ADODB.Recordset")
Opdb_Conn.open DBtheStr
Opdb_sql_str="select * from "&Opentdname
Opdb_Rs.open Opdb_Sql_Str,Opdb_Conn,1,1
Nfieldnumber=Opdb_Rs.Fields.count
If Nfieldnumber >0 then
Response.write "" & vbCrlf
For i=0 to (Nfieldnumber-1)
Response.write "" & vbCrlf
Next
temptbi=0
Do While Not Opdb_Rs.Eof
Response.write "" & vbCrlf
For i=0 to (Nfieldnumber-1)
If (temptbi<2) Then
Response.write "" & vbCrlf
temptbi=temptbi+1
Else
Response.write "" & vbCrlf
If temptbi>=3 Then
temptbi=0
Else
temptbi=temptbi+1
End If
End If
Next
Opdb_Rs.MoveNext
Response.write "" & vbCrlf
Loop
End If
Opdb_Rs.Close
Opdb_Conn.Close
Set Opdb_Rs = Nothing
Set Opdb_Conn=Nothing
Response.write "

" Response.write Trim(Opdb_Rs.Fields(i).Name) Response.write "
" Response.write Trim(Opdb_Rs.Fields(i)) Response.write "	" Response.write Trim(Opdb_Rs.Fields(i)) Response.write "

" & vbCrlf
End function

'**************************************************
'函数ID：0004[读取两种路径]
'函数名：Readsyspath
'作 用：读取路径
'参 数：lx ---- 0:服务器IP加路径 1:服务物理路径
'返回值：路径字串
'**************************************************
Public Function Readsyspath(ByVal lx)
Dim templj,aryTemp,newpath
templj=""
newpath=""
If lx=0 Then
templj="http://"&Request("SERVER_NAME")&Request("PATH_INFO")
aryTemp = Split(templj,"/")
Else
templj=Request("PATH_TRANSLATED")
aryTemp = Split(templj,"\")
End If
For i = LBound(aryTemp) To UBound(aryTemp)-1
If lx=0 Then
newpath=newpath&aryTemp(i)&"/"
Else
newpath=newpath&aryTemp(i)&"\"
End If
Next
Readsyspath=newpath
End Function

'**************************************************
'函数ID：0005[测试某个文件存在否]
'函数名：CheckFile
'作 用：测试某个文件存在否
'参 数：ckFilename ---- 被测试的文件名（包括路径）
'返回值：文件存在返回True,否则False
'**************************************************
Public Function CheckFile(ByVal ckFilename)
Dim M_fso
CheckFile=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If M_fso.FileExists(ckFilename) Then
CheckFile=True
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0006[删除某个文件]
'函数名：DelFile
'作 用：删除某个文件
'参 数：dFilename ---- 被删除的文件名（包括路径）
'返回值：文件删除返回True,否则False
'**************************************************
Public Function DelFile(ByVal dFilename)
Dim M_fso
DelFile=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If M_fso.FileExists(dFilename) Then
M_fso.DeleteFile(dFilename)
DelFile=True
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0007[判断目录是否存在]
'函数名：CheckDir
'作 用：判断目录是否存在
'参 数：ckDirname ---- 目录名（包括路径）
'返回值：目录存在返回True,否则False
'**************************************************
Public Function CheckDir(ByVal ckDirname)
Dim M_fso
CheckDir=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(ckDirname)) Then
CheckDir=True
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0008[创建目录]
'函数名：CreateDir
'作 用：创建目录
'参 数：crDirname ---- 目录名（包括路径）
'返回值：目录创建成功返回True,否则False
'**************************************************
Public Function CreateDir(ByVal crDirname)
Dim M_fso
CreateDir=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(crDirname)) Then
CreateDir=False
Else
M_fso.CreateFolder(crDirname)
CreateDir=True
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0009[删除目录]
'函数名：DelDir
'作 用：删除目录
'参 数：DlDirname ---- 目录名（包括路径）
'返回值：目录删除成功返回True,否则False
'**************************************************
Public Function DelDir(ByVal DlDirname)
Dim M_fso
DelDir=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(DlDirname)) Then
M_fso.DeleteFolder(DlDirname)
DelDir=True
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0010[指定目录的文件列表]
'函数名：ListFiles
'作 用：指定目录的文件列表
'参 数：Dirname ---- 目录名（包括路径）
'返回值：文件列表字符串，之间用“|”相隔
'**************************************************
Public Function ListFiles(ByVal Dirname)
Dim M_fso,fNS,fLS,Fnames,FnamesN
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(Dirname)) Then
Set fNS = M_fso.GetFolder(Dirname)
Set fLS=fNS.Files
For Each FnamesN in fLS
Fnames=Fnames & FnamesN.name
Fnames=Fnames & "|"
Next
ListFiles=Fnames
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0011[指定目录的目录列表]
'函数名：ListDirs
'作 用：指定目录的目录列表
'参 数：Dirname ---- 目录名（包括路径）
'返回值：目录列表字符串，之间用“|”相隔
'**************************************************
Public Function ListDirs(ByVal Dirname)
Dim M_fso,fNS,fLS,Fnames,FnamesN
Set M_fso = CreateObject("Scripting.FileSystemObject")
If (M_fso.FolderExists(Dirname)) Then
Set fNS = M_fso.GetFolder(Dirname)
Set fLS=fNS.SubFolders
For Each FnamesN in fLS
Fnames=Fnames & FnamesN.name
Fnames=Fnames & "|"
Next
ListDirs=Fnames
End If
Set M_fso = Nothing
End Function

'**************************************************
'函数ID：0012[创建文本文件]
'函数名：WritTextFile
'作 用：创建文本文件
'参 数：Fname ---- 文本文件名称（包括路径）
'参 数：WritString ---- 写入的内容
'返回值：创建成功返回True，否则False
'**************************************************
Public Function WritTextFile(ByVal Fname,ByVal WritString)
Dim M_fso,FnameN
WritTextFile=False
Set M_fso = CreateObject("Scripting.FileSystemObject")
Set FnameN= M_fso.OpenTextFile(Fname,2,True)
FnameN.Write WritString
FnameN.Close
Set M_fso = Nothing
WritTextFile=True
End Function

'**************************************************
'函数ID：0013[读取文本文件]
'函数名：ReadTextFile
'作 用：读取文本文件
'参 数：Fname ---- 文本文件名称（包括路径）
'返回值：返回读取的文本内容
'**************************************************
Public Function ReadTextFile(ByVal Fname)
Dim M_fso,FnameN,Fnr
ReadTextFile=""
Set M_fso = CreateObject("Scripting.FileSystemObject")
Set FnameN= M_fso.OpenTextFile(Fname,1,True)
Fnr=FnameN.ReadAll
FnameN.Close
Set M_fso = Nothing
ReadTextFile=Fnr
End Function

'**************************************************
'函数ID：0014[检测ID是否为数字类型]
'函数名：JCID
'作 用：检测ID是否为数字类型
'参 数：ParaValue ---- 被检测的ID值
'返回值：返回ID值，如果不为数字类型返回0
'**************************************************
Public Function JCID(ByVal ParaValue)
If Not isNumeric(ParaValue) Then
JCID="0"
Else
JCID=ParaValue
End If
End function

'**************************************************
'函数ID：0015[正则表达式测试]
'函数名：CheckExp
'作 用：正则表达式测试
'参 数：patrn ---- 正则表达式
'参 数：strng ---- 要测试的字符串
'返回值：测试如果成立返回 True 否则 False
'例 CheckExp("(\<.[^\<]*\>)","
")
'**************************************************
Public Function CheckExp(ByVal patrn, ByVal strng)
Dim regEx, retVal
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = False
retVal = regEx.Test(strng)
CheckExp = retVal
End Function

'**************************************************
'函数ID：0016[获得执行程序的名称]
'函数名：GT_the_proname
'作 用：获得执行程序的名称
'参 数：
'返回值：返回执行程序的名称
'**************************************************
Public Function GT_the_proname()
Dim temp_name,temp,tempsiz
temp=Request.ServerVariables("PATH_INFO")
temp_name=Split(temp, "/", -1, 1)
tempsiz=UBound(temp_name)
GT_the_proname=temp_name(tempsiz)
End function

'**************************************************
'函数ID：0017[读取用户IP地址信息]
'函数名：Readusip
'作 用：读取用户IP地址信息
'参 数：
'返回值：返回用户IP地址
'**************************************************
Public Function Readusip()
Dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
Readusip = Trim(Mid(strIPAddr, 1, 30))
End Function

'**************************************************
'函数ID：0018[无组件上传文件到指定目录并改文件名称]
'函数名：UpFsRn
'作 用：无组件上传文件到指定目录并更改文件名称
'参 数：Swj ---- 源文件（含路径）
'参 数：Fdir ---- 目标路径
'参 数：Objwj ---- 目标文件名称
'返回值：如果成功 True 否则 False
'例 UpFsRn(Tempwj,Readsyspath(1)&"zfkhauto","test.txt")
'使用表单提取文件
'**************************************************
Function UpFsRn(ByVal Swj,ByVal Fdir,ByVal Objwj)
UpFsRn=False
DIM strFileName,strFileDir,ObjAllPath
strFileDir = Fdir
strFileName = Swj
ObjAllPath = ""
If Right(strFileDir,1)<>"\" Then strFileDir=strFileDir&"\"
ObjAllPath =strFileDir&Objwj
If CheckFile(ObjAllPath) Then DelFile(ObjAllPath)
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 ''' adTypeBinary
objStream.Open
objStream.LoadFromFile strFileName
objStream.SaveToFile ObjAllPath,2
UpFsRn=True
objStream.Close
End function

'**************************************************
'函数ID：0019[过滤HTML脚本]
'函数名：FilterJS
'作 用：过滤HTML脚本
'参 数：strHTML ---- 被检测的HTML字串
'返回值：返回过滤后的HTML
'**************************************************
Function FilterJS(ByVal strHTML)
Dim objReg,strContent
If IsNull(strHTML) or strHTML="" Then Exit Function
Set objReg=New RegExp
objReg.IgnoreCase =True
objReg.Global=True
objReg.Pattern="(&#)"
strContent=objReg.Replace(strHTML,"")
objReg.Pattern="(function|meta|value|window\.|script|js:|about:|file:|Document\.|vbs:|frame|cookie)"
strContent=objReg.Replace(strContent,"")
objReg.Pattern="(on(finish|mouse|Exit=|error|click|key|load|focus|Blur))"
strContent=objReg.Replace(strContent,"")
FilterJS=strContent
strContent=""
Set objReg=Nothing
End Function

'**************************************************
'函数ID：0020[创建MsAccess数据库]
'函数名：CrDb_MsAccess
'作 用：创建MsAccess数据库
'参 数：DbPath ---- 目标目录信息
'参 数：DbFileName ---- 目标库文件名称
'参 数：DbUpwd ---- 目标库打开密码
'返回值：建立成功返回 True 否则 False
'**************************************************
Public Function CrDb_MsAccess(ByVal DbPath,ByVal DbFileName,ByVal DbUpwd)
CrDb_MsAccess=False
DIM fxztxt,temp_temp_db_str,temp_db_str
fxztxt=Chr(60)&"%Response.end()%"&Chr(62)
If Right(DbPath,1)<>"\" Then DbPath=DbPath & "\"
temp_temp_db_str="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&"temp.mdb;"
temp_db_str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&DbFileName&";Jet OLEDB:Database Password="&DbUpwd&";"
Set temp_Ca = Server.CreateObject("ADOX.Catalog")
temp_Ca.Create temp_temp_db_str
Set temp_Ca = Nothing
Set temp_Je = Server.CreateObject("JRO.JetEngine")
temp_Je.CompactDatabase temp_temp_db_str,temp_db_str
Set temp_fso = CreateObject("Scripting.FileSystemObject")
temp_fso.DeleteFile(DbPath&"temp.mdb")
Set temp_Je = Nothing
Set temp_fso = Nothing
set temp_Conn =server.createobject("ADODB.Connection")
set temp_Rs =server.createobject("ADODB.Recordset")
temp_Conn.open temp_db_str
temp_Sql_Str="Create TABLE [0] ([0] Text DEFAULT Notxt NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"
temp_Conn.Execute(temp_Sql_Str)
temp_Sql_Str="Select * From [0]"
temp_Rs.open temp_Sql_Str,temp_Conn,1,3
temp_Rs.addnew
temp_Rs("0")=fxztxt
temp_Rs.update
temp_Rs.Close
temp_Conn.Close
Set temp_Rs = Nothing
Set temp_Conn = Nothing
CrDb_MsAccess=True
End function

'**************************************************
'函数ID：0021[创建MsSQLServer数据库]
'函数名：CrDb_MsSQLServer
'作 用：创建MsSQLServer数据库
'参 数：DbIp ---- 数据库所在IP或主机名称
'参 数：DbSamc ---- 数据库超管用户名称
'参 数：DbSapwd---- 数据库超管用户口令
'参 数：DbName ---- 新建数据库名称
'参 数：DbUpmc ---- 新建数据库所属用户名称
'参 数：DbUpwd ---- 新建数据库所属用户密码
'返回值：建立成功返回 True 否则 False
'**************************************************
Public Function CrDb_MsSQLServer(ByVal DbIp,ByVal DbSamc,ByVal DbSapwd,ByVal DbName,ByVal DbUpmc,ByVal DbUpwd)
CrDb_MsSQLServer=False
DIM Temp_Sa_Str,Temp_Ua_Str,temp_Conn,temp_Rs,temp_Sql_Str,fxztxt
fxztxt=Chr(60)&"%Response.end()%"&Chr(62)
Temp_Sa_Str ="DRIVER=SQL Server;UID="&DbSamc&";DATABASE=master;SERVER="&DbIp&";PWD="&DbSapwd&";"
Temp_Ua_Str ="DRIVER=SQL Server;UID="&DbUpmc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbUpwd&";"
Set temp_Conn = Server.CreateObject("ADODB.Connection")
temp_Conn.Open Temp_Sa_Str
temp_Conn.Execute "Create DATABASE " &DbName
temp_Conn.Close
temp_DB_Conn_Str="DRIVER=SQL Server;UID="&DbSamc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbSapwd&";"
temp_Conn.Open temp_DB_Conn_Str
temp_Sql_Str="EXEC sp_addlogin '"&DbUpmc&"','"&DbUpwd&"','"&DbName&"'"
temp_Conn.Execute temp_Sql_Str
temp_Sql_Str="EXEC sp_grantdbaccess '"&DbUpmc&"'"
temp_Conn.Execute temp_Sql_Str
temp_Sql_Str="EXEC sp_addrolemember 'db_owner', '"&DbUpmc&"'"
temp_Conn.Execute temp_Sql_Str
temp_Sql_Str="EXEC sp_defaultdb "&DbUpmc&","&DbName
temp_Conn.Execute temp_Sql_Str
temp_Conn.Close
temp_Conn.open Temp_Ua_Str
temp_Sql_Str="Create TABLE [0] ([00] Text NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"
temp_Conn.Execute temp_Sql_Str
Set temp_Rs=server.createobject("ADODB.Recordset")
temp_Sql_Str="Select * From [0]"
temp_Rs.open temp_Sql_Str,temp_Conn,1,3
temp_Rs.addnew
temp_Rs("00")=fxztxt
temp_Rs.update
temp_Rs.Close
temp_Conn.Close
Set temp_Rs = Nothing
Set temp_Conn=Nothing
CrDb_MsSQLServer=True
End function

''Response.write "例子"

%>