ASP函数库
<%
''''                   函数目录                    ''''
''''-----------------------------------------------''''
'''' 函数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：0022[通过JMAIL发信]                   ''''
'''' 函数ID：0023[测试组件是否安装]                ''''
'''' 函数ID：0024[上传文件的窗口]                  ''''
'''' 函数ID：0025[取得数据库链接字串]              ''''
'''' 函数ID：0026[取得multipart/form-data形式上传文件]
'''' 函数ID：0027[保存或查看上传到数据库中的数据，带调用上传窗口]
'''' 函数ID：0028[取得图像的类型|宽|高]            ''''
'''' 函数ID：0029[将本地文件进行二进制分析，并保存到服务器的指定目录下]
'''' 函数ID：0030[将本地数据表或库上传并导入到服务器数据库的表中]
'''' 函数ID：0031[返回服务器信息]                  ''''
'''' 函数ID：0032[产生20位长度的唯一标识ID]        ''''
'''' 函数ID：0033[用于左填充指定数量的字符]        ''''
'''' 函数ID：0034[用于右填充指定数量的字符]        ''''
'''' 函数ID：0035[格式化时间(显示)]                ''''
'''' 函数ID：0036[测试数据库是否存在]              ''''
'''' 函数ID：0037[测试数据库中的表是否存在]        ''''
'''' 函数ID：0038[在线HTML编辑器]                  ''''
'''' 函数ID：0039[判断是否奇数]                    ''''
'''' 函数ID：0040[生成验证码图像BMP]               ''''
'''' 函数ID：0041[生成随机密码]                    ''''
'''' 函数ID：0042[字符加解密]                      ''''
'''' 函数ID：0043[解密字符加解密]                  ''''
'''' 函数ID：0044[创建数据表]                      ''''
'''' 函数ID：0045[在数据库中插入字段值]            ''''
'''' 函数ID：0046[Cookie防乱码写入时用]            ''''
'''' 函数ID：0047[Cookie防乱码读出时用]            ''''
'''' 函数ID：0048[检测用户名和密码是否正确]        ''''
'''' 函数ID：0049[生成时间的整数]                  ''''
'''' 函数ID：0050[获得栏目的所有子栏目字符串并用","隔开]
''''                                               ''''
''''                                               ''''
''''                                               ''''
'**************************************************''''
'函数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
    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://%22&request(%22server_name%22)&request(%22path_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)) OR (Trim(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 fu_name,temp,tempsiz
  temp=Request.ServerVariables("PATH_INFO")
  fu_name=Split(temp, "/", -1, 1)
  tempsiz=UBound(fu_name)
  GT_the_proname=fu_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
'作 用：无组件上传文件到指定目录并更改文件名称
'参 数：RetSize--- 上传限止大小（单位是M）
'参 数：Fdir  ---- 目标路径
'参 数：Objwj ---- 目标文件名称
'返回值：如果成功 True 否则 False
'例 UpFsRn(10,Readsyspath(1)&"zfkhauto","test.txt")
'使用表单提取文件