ASP函数库

海门银

海门银

2016-02-19 19:31

每个人都希望每天都是开心的,不要因为一些琐事扰乱了心情还,闲暇的时间怎么打发,关注图老师可以让你学习更多的好东西,下面为大家推荐ASP函数库,赶紧看过来吧!

  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 "table border='0' width='100%' cellspacing='0' cellpadding='0'" & 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 "tr" & vbCrlf
       For i=0 to (Nfieldnumber-1)
           Response.write "td style='border-style: ridge; border-width: 1' bgcolor='#E1E1E1' valign='middle' align='center'"
           Response.write Trim(Opdb_Rs.Fields(i).Name)
           Response.write "/td" & vbCrlf
       Next
       temptbi=0
       Do While Not Opdb_Rs.Eof
          Response.write "/tr" & vbCrlf
          For i=0 to (Nfieldnumber-1)
              If (temptbi2) Then
                  Response.write "td style='border-style: ridge; border-width: 1' bgcolor='#F6F6F6' valign='middle'"
                  Response.write Trim(Opdb_Rs.Fields(i))
                  Response.write "/td" & vbCrlf
                  temptbi=temptbi+1
              Else
                  Response.write "td style='border-style: ridge; border-width: 1' valign='middle'"
                  Response.write Trim(Opdb_Rs.Fields(i))
                  Response.write "/td" & vbCrlf
                  If temptbi=3 Then
                     temptbi=0
                  Else
                     temptbi=temptbi+1
                  End If
              End If
          Next
          Opdb_Rs.MoveNext
          Response.write "/tr" & vbCrlf
       Loop
    End If
    Opdb_Rs.Close
    Opdb_Conn.Close
    Set Opdb_Rs = Nothing
    Set Opdb_Conn=Nothing
    Response.write "/table" & 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)) OR (Trim(ParaValue)="")) Then
       JCID=0
    Else
       JCID=ParaValue
    End If
  End function
  '**************************************************
  '函数ID:0015[正则表达式测试]
  '函数名:CheckExp
  '作 用:正则表达式测试
  '参 数:patrn ---- 正则表达式
  '参 数:strng ---- 要测试的字符串
  '返回值:测试如果成立返回 True 否则 False
  '例 CheckExp("(.[^]*)","br")
  '**************************************************
  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")
  '使用表单提取文件 form method='POST' action='function.asp' enctype='multipart/form-data'input type='file' name='T1'input type='submit' value='提交' name='B1'/form
  '**************************************************
  Public Function UpFsRn(ByVal RetSize,ByVal Fdir,ByVal Objwj)
    UpFsRn=False
    Dim oUpStream,oStream,formsize,Formdata,strFileName,strFileDir,ObjAllPath,datastart,dataend
    strFileDir  = Fdir
    strFileName = Swj
    ObjAllPath  = ""
    If Right(strFileDir,1)"" Then strFileDir=strFileDir&""
    ObjAllPath  =strFileDir&Objwj
    If CheckFile(ObjAllPath) Then DelFile(ObjAllPath)
    formsize=Request.TotalBytes
    if (formsize=(RetSize*1024*1024)) then
       Formdata=Request.BinaryRead(formsize)
       Pos_ts=LenB(getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))
       Pos_b=InstrB(Formdata,getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))+Pos_ts
       nFormdata=MidB(Formdata,Pos_b)
       Pos_ts=InstrB(nFormdata,getByteString(Chr(13) & Chr(10) & "--"))
       nnFormdata=MidB(nFormdata,Pos_ts)
       Pos_e=LenB(Formdata)-LenB(nnFormdata)-Pos_b+1
       datastart =Pos_b
       dataend=Pos_e
       set oUpStream = Server.CreateObject("adodb.stream")
       oUpStream.Type = 1
       oUpStream.Mode = 3
       oUpStream.Open
       set oStream = Server.CreateObject("adodb.stream")
       oStream.Type = 1
       oStream.Mode = 3
       oStream.Open
       oUpStream.Write Formdata
       oUpStream.position=datastart-1
       oUpStream.copyto oStream,dataend
       oStream.SaveToFile ObjAllPath,2
       oStream.Close
       set oStream=nothing
       UpFsRn=True
    End If
  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
    On Error GoTo 0
    On Error Resume Next
    DIM fxztxt,fu_fu_db_str,fu_db_str
    fxztxt=Chr(60)&"%Response.end()%"&Chr(62)
    If Right(DbPath,1)"" Then DbPath=DbPath & ""
    fu_fu_db_str="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&"temp.mdb;"
    fu_db_str     ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&DbFileName&";Jet OLEDB:Database Password="&DbUpwd&";"
    Set fu_Ca = Server.CreateObject("ADOX.Catalog")
    fu_Ca.Create fu_fu_db_str
    Set fu_Ca = Nothing
    Set fu_Je = Server.CreateObject("JRO.JetEngine")
    fu_Je.CompactDatabase fu_fu_db_str,fu_db_str
    Set fu_fso = CreateObject("Scripting.FileSystemObject")
    fu_fso.DeleteFile(DbPath&"temp.mdb")
    Set fu_Je   = Nothing
    Set fu_fso  = Nothing
    set fu_Conn =server.createobject("ADODB.Connection")
    set fu_Rs   =server.createobject("ADODB.Recordset")
    fu_Conn.open fu_db_str
    fu_Sql_Str="CREATE TABLE [0] ([0] Text DEFAULT Notxt NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"
    fu_Conn.Execute(fu_Sql_Str)
    fu_Sql_Str="Select * From [0]"
    fu_Rs.open fu_Sql_Str,fu_Conn,1,3
    fu_Rs.addnew
    fu_Rs("0")=fxztxt
    fu_Rs.update
    fu_Rs.Close
    fu_Conn.Close
    Set fu_Rs = Nothing
    Set fu_Conn = Nothing
    If Err.Number = 0 Then
       CrDb_MsAccess=True
    End If
    On Error GoTo 0
  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
    On Error GoTo 0
    On Error Resume Next
    DIM fu_Sa_Str,fu_Ua_Str,fu_Conn,fu_Rs,fu_Sql_Str,fxztxt
    fxztxt=Chr(60)&"%Response.end()%"&Chr(62)
    fu_Sa_Str  ="DRIVER=SQL Server;UID="&DbSamc&";DATABASE=master;SERVER="&DbIp&";PWD="&DbSapwd&";"
    fu_Ua_Str  ="DRIVER=SQL Server;UID="&DbUpmc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbUpwd&";"
    Set fu_Conn = Server.CreateObject("ADODB.Connection")
    fu_Conn.Open fu_Sa_Str
    fu_Conn.Execute "CREATE DATABASE " &DbName
    fu_Conn.Close
    fu_DB_Conn_Str="DRIVER=SQL Server;UID="&DbSamc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbSapwd&";"
    fu_Conn.Open fu_DB_Conn_Str
    fu_Sql_Str="EXEC sp_addlogin '"&DbUpmc&"','"&DbUpwd&"','"&DbName&"'"
    fu_Conn.Execute fu_Sql_Str
    fu_Sql_Str="EXEC sp_grantdbaccess '"&DbUpmc&"'"
    fu_Conn.Execute fu_Sql_Str
    fu_Sql_Str="EXEC sp_addrolemember 'db_owner', '"&DbUpmc&"'"
    fu_Conn.Execute fu_Sql_Str
    fu_Sql_Str="EXEC sp_defaultdb "&DbUpmc&","&DbName
    fu_Conn.Execute fu_Sql_Str
    fu_Conn.Close
    fu_Conn.open fu_Ua_Str
    fu_Sql_Str="CREATE TABLE [0] ([0] Text DEFAULT ('Notxt') NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"
    fu_Conn.Execute fu_Sql_Str
    Set fu_Rs=server.createobject("ADODB.Recordset")
    fu_Sql_Str="Select * From [0]"
    fu_Rs.open fu_Sql_Str,fu_Conn,1,3
    fu_Rs.addnew
    fu_Rs("0")=fxztxt
    fu_Rs.update
    fu_Rs.Close
    fu_Conn.Close
    Set fu_Rs = Nothing
    Set fu_Conn=Nothing
    If Err.Number = 0 Then
       CrDb_MsSQLServer=True
    End If
    On Error GoTo 0
  End function
  '**************************************************
  '函数ID:0022[通过JMAIL发信]
  '函数名:MSMail
  '作 用:通过JMAIL发信
  '参 数:subject      ---- 邮件的标题
  '参 数:mailaddress  ---- 邮件服务器地址
  '参 数:senderName   ---- 发件人名称
  '参 数:email        ---- 收件人E-MAIL地址
  '参 数:content      ---- 邮件内容
  '参 数:fromer       ---- 发件人E-MAIL地址
  '参 数:serEmailUser ---- 邮件服务器权限用户名
  '参 数:serEmailPass ---- 邮件服务器权限用户密码
  '返回值:发送成功返回 True 否则 False
  '示 例:MSMail("test","smtp.163.com","mzy","mzymcm@yahoo.com.cn","test","mzymcm@163.com","mzymcm","abcmzy1029abc")
  '**************************************************
  Public Function MSMail(ByVal subject, ByVal mailaddress, ByVal senderName, ByVal email, ByVal content, ByVal fromer, ByVal serEmailUser, ByVal serEmailPass)
    dim JmailMsg
    MSMail=False
    set JmailMsg=server.createobject("jmail.message")
    JmailMsg.mailserverusername=serEmailUser
    JmailMsg.mailserverpassword=serEmailPass
    JmailMsg.addrecipient email
    JmailMsg.from=fromer
    JmailMsg.fromname=senderName
    JmailMsg.charset="gb2312"
    JmailMsg.logging=true
    JmailMsg.silent=true
    JmailMsg.subject=Subject
    JmailMsg.body=Server.HTMLEncode(content)
    JmailMsg.htmlbody=content
    if not JmailMsg.send(mailaddress) then
        MSMail=False
    else
        MSMail=True
    end if
    JmailMsg.close
    set JmailMsg=nothing
  End function
  '**************************************************
  '函数ID:0023[测试组件是否安装]
  '函数名:IsObjInstalled
  '作 用:测试组件是否安装
  '参 数:strClassString ---- 组件名称或标识字串
  '返回值:测试成功返回 True 否则 False
  '示 例:IsObjInstalled("JMAIL.Message")
  '**************************************************
  Public Function IsObjInstalled(ByVal strClassString)
    On Error Resume Next
    IsObjInstalled = False
    Err = 0
    Dim xTestObj
    Set xTestObj = Server.CreateObject(strClassString)
    If 0 = Err Then IsObjInstalled = True
    Set xTestObj = Nothing
    Err = 0
  End Function
  '**************************************************
  '函数名:GetObjVer
  '作 用:返回组件版本信息
  '参 数:strClassString ---- 组件名称或标识字串
  '返回值:返回组件版本信息字串
  '示 例:GetObjVer("JMAIL.Message")
  '**************************************************
  Public Function GetObjVer(ByVal strClassString)
    On Error Resume Next
    GetObjVer=""
    Err = 0
    Dim xTestObj
    Set xTestObj = Server.CreateObject(strClassString)
    If 0 = Err Then GetObjVer=xtestobj.version
    Set xTestObj = Nothing
    Err = 0
  End Function
  '**************************************************
  '函数名:ListObjInfo
  '作 用:列出组件安装信息
  '参 数: ----
  '返回值:列出组件安装信息
  '示 例:ListObjInfo()
  '**************************************************
  Public Function ListObjInfo()
    Dim TempBs,TempBsXX,TempObjType,tmpObjs
    TempBs="×"
    TempBsXX=""
    TempObjType=""
    tmpObjs=""
    tmpObjs=tmpObjs& "JMail.Message|"
    tmpObjs=tmpObjs& "ADODB.Stream|"
    tmpObjs=tmpObjs& "MSWC.AdRotator|"
    tmpObjs=tmpObjs& "MSWC.BrowserType|"
    tmpObjs=tmpObjs& "MSWC.NextLink|"
    tmpObjs=tmpObjs& "MSWC.Tools|"
    tmpObjs=tmpObjs& "MSWC.Status|"
    tmpObjs=tmpObjs& "MSWC.Counters|"
    tmpObjs=tmpObjs& "MSWC.PermissionChecker|"
    tmpObjs=tmpObjs& "Scripting.FileSystemObject|"
    tmpObjs=tmpObjs& "adodb.connection|"
    tmpObjs=tmpObjs& "SoftArtisans.FileUp|"
    tmpObjs=tmpObjs& "SoftArtisans.FileManager|"
    tmpObjs=tmpObjs& "CDONTS.NewMail|"
    tmpObjs=tmpObjs& "Persits.MailSender|"
    tmpObjs=tmpObjs& "LyfUpload.UploadFile|"
    tmpObjs=tmpObjs& "Persits.Upload.1|"
    tmpObjs=tmpObjs& "w3.upload|"
    tmpObjs=Split(tmpObjs,"|")
    Response.write "centertable border='1' bordercolor='#000000' cellspacing='0' cellpadding='0' style='font-size: 9pt;""宋体'trtd width='33%' valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'组件标识/tdtd width='33%' valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'√|×/tdtd width='34%' valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'版本/td/tr" & vbCrlf
    For i = LBound(tmpObjs) To UBound(tmpObjs)
        If Trim(tmpObjs(i))"" Then
           If IsObjInstalled(tmpObjs(i)) Then
              TempObjType=tmpObjs(i)
              TempBs="√"
              TempBsXX=GetObjVer(tmpObjs(i))
              If TempBsXX="" Then TempBsXX=" "
           Else
              TempObjType="font color='#800000'"&tmpObjs(i)&"/font"
              TempBs="font color='#800000'×/font"
              TempBsXX=" "
           End If
           Response.write "tr" & vbCrlf
           Response.write "td valign='middle' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'"&TempObjType&"/td" & vbCrlf
           Response.write "td valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'"&TempBs&"/td" & vbCrlf
           Response.write "td valign='middle' align='center' style='border-left: 1 solid #808080; border-right: 1 solid #FFFFFF; border-top: 1 solid #FFFFFF; border-bottom: 1 solid #808080; padding-left: 2; padding-right: 2; padding-top: 1; padding-bottom: 1'"&TempBsXX&"/td" & vbCrlf
           Response.write "/tr" & vbCrlf
        End If
    Next
    Response.write "/table/center" & vbCrlf
  End Function
  '**************************************************
  '函数ID:0024[上传文件的窗口]
  '函数名:PosImageWin
  '作 用:上传选择文件窗口,可自动提取文件名及类型
  '参 数:PfUrlstr ---- 处理二进制文件信息的URL地址
  '返回值:网页HTML文件
  '示 例:库结构例子 CREATE TABLE [IMAGES]  ([ID] int IDENTITY (1,1) NOT NULL PRIMARY KEY,[MC]  varchar(50),[LX] varchar(20),[MEM] Text,[IMGS] image)
  '**************************************************
  Public Function PosImageWin(ByVal PfUrlstr)
    PosImageWin=""
    PosImageWin=PosImageWin &  "centertable border='0' width='0' cellspacing='0' cellpadding='0' style='font-size: 9pt'" & vbCrlf
    PosImageWin=PosImageWin &  "SCRIPT LANGUAGE=JAVASCRIPT"&vbCrlf
    PosImageWin=PosImageWin &  "function ckfilelx(){"&vbCrlf
    PosImageWin=PosImageWin &  "tempwjm=POFile.ImageFs.value;"&vbCrlf
    PosImageWin=PosImageWin &  "fgwjm=tempwjm.split('.');"&vbCrlf
    PosImageWin=PosImageWin &  "newwjm=fgwjm.reverse();"&vbCrlf
    PosImageWin=PosImageWin &  "POMem.ImageType.value=newwjm[0].toUpperCase();"&vbCrlf
    PosImageWin=PosImageWin &  "tempwjm=newwjm[1].toUpperCase();"&vbCrlf
    PosImageWin=PosImageWin &  "fgwjm=tempwjm.split('');"&vbCrlf
    PosImageWin=PosImageWin &  "newwjm=fgwjm.reverse();"&vbCrlf
    PosImageWin=PosImageWin &  "POMem.ImageName.value=newwjm[0].toUpperCase();"&vbCrlf
    PosImageWin=PosImageWin &  "POMem.ImageReadme.value=newwjm[0].toUpperCase();"&vbCrlf
    PosImageWin=PosImageWin &  "}"&vbCrlf
    PosImageWin=PosImageWin &  "function Reedit(){POFile.reset();POMem.reset();}"&vbCrlf
    PosImageWin=PosImageWin &  "function PostDo(){if (POFile.ImageFs.value==''){alert('没有选择文件哟!');}else{bc.innerHTML='正在上传,请稍后...';POFile.action=POFile.action+'&mc='+POMem.ImageName.value+'&lx='+POMem.ImageType.value+'&mem='+POMem.ImageReadme.value;bc.style.visibility='visible';ReEd.disabled=true;PoSe.disabled=true;POFile.submit();POFile.ImageFs.disabled=true;}}"&vbCrlf
    PosImageWin=PosImageWin &  "/SCRIPT"&vbCrlf
    PosImageWin=PosImageWin &  "trform method='POST' name='POFile' enctype='multipart/form-data' ACTION='"&PfUrlstr&"' target='tempa'td width='100%' valign='middle'" & vbCrlf
    PosImageWin=PosImageWin &  "选择文件:input type='file' name='ImageFs' ONCHANGE='ckfilelx();' style='font-size: 9pt;width:300;'" & vbCrlf
    PosImageWin=PosImageWin &  "/td/form/tr" & vbCrlf
    PosImageWin=PosImageWin &  "trform method='POST' name='POMem'td width='100%' valign='middle'" & vbCrlf
    PosImageWin=PosImageWin &  "文件ID号:input type='text' name='ImageID' ReadOnly  style='font-size: 9pt;width:300;'br" & vbCrlf
    PosImageWin=PosImageWin &  "文件名称:input type='text' name='ImageName'  style='font-size: 9pt;width:300;'br" & vbCrlf
    PosImageWin=PosImageWin &  "文件类型:input type='text' name='ImageType' ReadOnly style='font-size: 9pt;width:300;'br" & vbCrlf
    PosImageWin=PosImageWin &  "文件介绍:textarea rows='8' name='ImageReadme' cols='20' style='font-size: 9pt;width:300;'还没有/textarea" & vbCrlf
    PosImageWin=PosImageWin &  "/td/form/tr" & vbCrlf
    PosImageWin=PosImageWin &  "trtd width='100%' valign='middle' align='center'" & vbCrlf
    PosImageWin=PosImageWin &  "input type='button' value='重置' name='ReEd' OnClick='Reedit();'  input type='button' value='上传' name='PoSe' OnClick='PostDo();'" & vbCrlf
    PosImageWin=PosImageWin &  "/td/tr/table/centerdiv id='bc' name='bc' style='position: absolute; left: 45%; top:40%; z-index: 0;background-color: #EAEAEA;visibility: hidden;' valign='middle' align='center'/div" & vbCrlf
    PosImageWin=PosImageWin &  "iframe src='' ID='tempa' NAME='tempa' frameborder='0' width='0' height='0' style='width:0;Height:0;'" & vbCrlf
  End Function
  '**************************************************
  '函数ID:0025[取得数据库链接字串]
  '函数名:GetConnStr
  '作 用:取得数据库链接字串,能生成MsAccess和MsSqlServer链接串
  '参 数:Lx         ---- 0 是MsAccess , 1 是MsSqlServer
  '参 数:Dbiporpath ---- 数据库IP或路径
  '参 数:Dbmc       ---- 数据库名称
  '参 数:Dbuid      ---- 数据库用户名称
  '参 数:Dbupwd     ---- 数据库用户密码
  '返回值:链接字串
  '示 例:http://school.cnd8.com/
  '**************************************************
  Public Function GetConnStr(ByVal Lx,ByVal Dbiporpath,ByVal Dbmc,ByVal Dbuid,ByVal Dbupwd)
    GetConnStr=""
    If Lx=0 Then
       If Right(Dbiporpath,1)"" Then Dbiporpath=Dbiporpath & ""
       GetConnStr ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&Dbiporpath&Dbmc&";Jet OLEDB:Database Password="&Dbupwd&";"
    End If
    If Lx=1 Then
       GetConnStr ="DRIVER=SQL Server;UID="&Dbuid&";DATABASE="&Dbmc&";SERVER="&Dbiporpath&";PWD="&Dbupwd&";"
    End If
  End Function
  '**************************************************
  '函数ID:0026[取得multipart/form-data形式上传文件]
  '函数名:GetImageData
  '作 用:取得multipart/form-data形式上传文件
  '参 数:MaxSize ---- 上传的限止大小,单位:M(兆)
  '返回值:二进制数据
  '示 例:
  '**************************************************
  Public Function GetImageData(ByVal MaxSize)
    GetImageData=""
    DIM formsize,Formdata,bncrlf,divider,datastart,dataend,mydata
    formsize=Request.TotalBytes
    if (formsize=(MaxSize*1024*1024)) then
       Formdata=Request.BinaryRead(formsize)
       Pos_ts=LenB(getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))
       Pos_b=InstrB(Formdata,getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))+Pos_ts
       nFormdata=MidB(Formdata,Pos_b)
       Pos_ts=InstrB(nFormdata,getByteString(Chr(13) & Chr(10) & "--"))
       nnFormdata=MidB(nFormdata,Pos_ts)
       Pos_e=LenB(Formdata)-LenB(nnFormdata)-Pos_b+1
       datastart =Pos_b
       dataend=Pos_e
       mydata=midb(Formdata,datastart,dataend)
    End If
    GetImageData=mydata
  End Function
  '''' 将字串转为二进制串
  Function getByteString(StringStr)
    For i=1 to Len(StringStr)
        char=Mid(StringStr,i,1)
        getByteString=getByteString & chrB(AscB(char))
    Next
  End function
  '**************************************************
  '函数ID:0027[保存或查看上传到数据库中的数据,带调用上传窗口]
  '函数名:GoImgToDb
  '作 用:保存或查看上传到数据库中的数据,带调用上传窗口
  '参 数:PPLX       ---- 执行类型(空为保存,ID号为查看该ID的文件)
  '参 数:PUrl       ---- 主执行程序的URL部份
  '参 数:ConnStr    ---- 上传文件的数据库链接字串
  '参 数:ImagTbname ---- 文件保存的数据表名称
  '参 数:Did        ---- 文件ID字段名
  '参 数:Dmc        ---- 文件名称字段名
  '参 数:Dlx        ---- 文件类型字段名
  '参 数:Dmem       ---- 文件说明字段名
  '参 数:Ddata      ---- 文件的二进制数据的字段名
  '参 数:MaxSize    ---- 上传的限止大小,单位:M(兆)
  '参 数:IDLX       ---- 标识ID字段的类型 ( 0 字符型 1 数值(非自增量型) 2 数值型(自增量型)  )
  '返回值:成功保存的JAVASCRIPT  注在非自动增量情况下标识字段长度应超过20个字符
  '示 例:GoImgToDb("17","http://127.0.0.1/function.asp",GetConnStr(1,"127.0.0.1","temp","sa","mzy1029"),"img","id","mc","lx","mem","data",20)
  '示 例:GoImgToDb("","http://127.0.0.1/function.asp",GetConnStr(1,"127.0.0.1","temp","sa","mzy1029"),"img","id","mc","lx","mem","data",20)
  '**************************************************
  Public Function GoImgToDb(ByVal PPLX,ByVal PUrl,ByVal ConnStr,ByVal ImagTbname,ByVal Did,ByVal Dmc,ByVal Dlx,ByVal Dmem,ByVal Ddata,ByVal MaxSize,ByVal IDLX)
    DIM Pjobs,Pjurl
    tempimg_conn_str=ConnStr
    Set fu_Conn=server.createobject("ADODB.Connection")
    Set fu_Rs=server.createobject("ADODB.Recordset")
    fu_Conn.open tempimg_conn_str
    If JCID(PPLX)=0 Then
       Pjobs=Request("img")
       If InStr(PUrl,"?")0 Then
          Pjurl=PUrl&"&img=sav"
       Else
          Pjurl=PUrl&"?img=sav"
       End If
       If Pjobs="" then Response.write PosImageWin(Pjurl)
       If Pjobs="sav" Then
          Sql_Str="SELECT "&Did&","&Dmc&","&Dlx&","&Dmem&","&Ddata&" FROM "&ImagTbname
          fu_Rs.open Sql_Str,fu_Conn,3,3
          fu_Rs.addnew
          If IDLX 2 Then
             fu_Rs(Did)  =MakeTheID()
          End If
          fu_Rs(Dmc)  =Request("mc")
          fu_Rs(Dlx)  =Request("lx")
          fu_Rs(Dmem) =Request("mem")
          fu_Rs(Ddata).AppendChunk GetImageData(JCID(MaxSize))
          fu_Rs.update
          fu_Rs.Close
          fu_Rs.open Sql_Str,fu_Conn,3,3
          fu_Rs.MoveLast
          Response.write "SCRIPT LANGUAGE=JAVASCRIPT"&vbCrlf
          Response.write "parent.POMem.ImageID.value='"&fu_Rs(Did)&"';"&vbCrlf
          Response.write "parent.bc.innerHTML='已成功保存数据!';"
          Response.write "/SCRIPT"&vbCrlf
        End If
    Else
       If IDLX 0 Then
          Sql_Str="SELECT "&Did&","&Dmc&","&Dlx&","&Dmem&","&Ddata&" FROM "&ImagTbname&" WHERE ("&Did&" ="&PPLX&")"
       Else
          Sql_Str="SELECT "&Did&","&Dmc&","&Dlx&","&Dmem&","&Ddata&" FROM "&ImagTbname&" WHERE ("&Did&" ='"&PPLX&"')"
       End If
       fu_Rs.open Sql_Str,fu_Conn,1,1
       If fu_Rs.RecordCount 0 Then
          tempaa=Trim(fu_Rs(Dlx))
          Response.Clear
          Response.Expires = -9999
          Response.AddHeader "pragma", "no-cache"
          Response.AddHeader "cache-ctrol", "no-cache"
          Response.Buffer = TRUE
          Response.AddHeader "Content-Disposition:","attachment;filename="&fu_Rs(Dmc)&"."&tempaa
          Response.ContentType="application/"&Trim(fu_Rs(Dlx))
          Response.Flush
          Response.BinaryWrite fu_Rs(Ddata)
          Response.End
       End If
    End If
    fu_Rs.Close
    fu_Conn.close
    Set fu_Rs = Nothing
    Set fu_Conn = Nothing
  End Function
  '**************************************************''''
  '函数ID:0028[取得图像的类型|宽|高]
  '函数名:GetImageDx
  '作 用:取得图像的类型|宽|高
  '参 数:filepath ---- 文件路径及文件命名
  '返回值:"类型|宽|高"
  '************************

展开更多 96%)
分享
qqQQ
qzoneQQ空间
weibo微博

猜你喜欢

ASP函数库

Web开发
ASP函数库

ASP实用函数库

ASP
ASP实用函数库

s8lol主宰符文怎么配

英雄联盟 网络游戏
s8lol主宰符文怎么配

javascript函数库

Web开发
javascript函数库

网络函数库

编程语言 网络编程
网络函数库

lol偷钱流符文搭配推荐

英雄联盟 网络游戏
lol偷钱流符文搭配推荐

WML Script标准函数库

Web开发
WML Script标准函数库

javascript函数库-集合框架

Web开发
javascript函数库-集合框架

lolAD刺客新符文搭配推荐

英雄联盟
lolAD刺客新符文搭配推荐

bpl和dll文件的区别[翻译]

bpl和dll文件的区别[翻译]

禁用html页面的缓存

禁用html页面的缓存
下拉加载更多内容 ↓