当前位置导航:炫浪网>>网络学院>>网页制作>>ASP教程

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, "&nbsp;", " "), "&quot;", Chr(34)), "&gt;", ">"), "&lt;", "<")
    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, " ", "&nbsp;"), Chr(34), "&quot;"), ">", "&gt;"), "<", "&lt;")
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 (temptbi<2) 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","[email protected]","test","[email protected]","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 "<center><table border='1' bordercolor='#000000' cellspacing='0' cellpadding='0' style='font-size: 9pt;"">宋体'><tr><td 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'>组件标识</td><td 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'>√|×</td><td 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="&nbsp;"
         Else
            TempObjType="<font color='#800000'>"&tmpObjs(i)&"</font>"
            TempBs="<font color='#800000'>×</font>"
            TempBsXX="&nbsp;"
         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 &  "<center><table 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 &  "<tr><form 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 &  "<tr><form 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 &  "<tr><td width='100%' valign='middle' align='center'>" & vbCrlf
  PosImageWin=PosImageWin &  "<input type='button' value='重置' name='ReEd' OnClick='Reedit();'>&nbsp;&nbsp;<input type='button' value='上传' name='PoSe' OnClick='PostDo();'>" & vbCrlf
  PosImageWin=PosImageWin &  "</td></tr></table></center><div 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://www.knowsky.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 ---- 文件路径及文件命名
'返回值:"类型|宽|高"
'**************************************************''''
Public Function GetImageDx(ByVal filepath)
  DIM Tempsm,NBxx,WJXX(3)
  SET Tempsm = Server.CreateObject("ADODB.Stream")
  Tempsm.Mode=3
  Tempsm.Type=1
  Tempsm.Open
  Tempsm.LoadFromFile filepath
  NBxx=Hex(BinVal(Tempsm.Read(3)))
  WJXX(0)=NBxx
  WJXX(1)="0"
  WJXX(2)="0"
  If NBxx="464947" Then
     WJXX(0)="GIF"
     Tempsm.Read(3)
     WJXX(1)=BinVal(Tempsm.Read(2))
     WJXX(2)=BinVal(Tempsm.Read(2))
  End If
  If NBxx="FFD8FF" Then
     WJXX(0)="JPG"
     do
     do: p1=binVal(Tempsm.Read(1)): loop while p1=255 and not Tempsm.EOS
     if p1>191 and p1<196 then exit do else Tempsm.Read(binval2(Tempsm.Read(2))-2)
     do:p1=binVal(Tempsm.Read(1)):loop while p1<255 and not Tempsm.EOS
     loop while true
     Tempsm.Read(3)
     WJXX(2)=binval2(Tempsm.Read(2))
     WJXX(1)=binval2(Tempsm.Read(2))
  End If
  If Mid(NBxx,3)="4D42" Then
     Tempsm.Read(15)
     WJXX(0)="BMP"
     WJXX(1)=binval(Tempsm.Read(4))
     WJXX(2)=binval(Tempsm.Read(4))
  End If
  If NBxx="4E5089" Then
     WJXX(0)="PNG"
     Tempsm.Read(15)
     WJXX(1)=BinVal2(Tempsm.Read(2))
     Tempsm.Read(2)
     WJXX(2)=BinVal2(Tempsm.Read(2))
  End If
  If NBxx="535743" Then
     WJXX(0)="SWF"
     Tempsm.Read(5)
     binData=Tempsm.Read(1)
     sConv=Num2Str(ascb(binData),2 ,8)
     nBits=Str2Num(left(sConv,5),2)
     sConv=mid(sConv,6)
     while(len(sConv)<nBits*4)
        binData=Tempsm.Read(1)
        sConv=sConv&Num2Str(ascb(binData),2 ,8)
     wend
     WJXX(1)=int(abs(Str2Num(mid(sConv,1*nBits+1,nBits),2)-Str2Num(mid(sConv,0*nBits+1,nBits),2))/20)
     WJXX(2)=int(abs(Str2Num(mid(sConv,3*nBits+1,nBits),2)-Str2Num(mid(sConv,2*nBits+1,nBits),2))/20)
  End If
  Tempsm.Close
  SET Tempsm=nothing
  GetImageDx = WJXX(0)&"|"&WJXX(1)&"|"&WJXX(2)
End Function
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
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
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
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
'**************************************************''''
'函数ID:0029[将本地文件进行二进制分析,并保存到服务器的指定目录下]
'函数名:TxtBinInfo
'作 用:将本地文件进行二进制分析,并保存到服务器的指定目录下
'参 数:Filestr ---- 被分析文件路径及文件命名
'参 数:WebSvFile ---- 分析信息保存文件路径及文件命名
'返回值:成功返回 True 否则 False
'示 例:  TempSj=Request.Form("Tfile")
'示 例:  If Trim(TempSj)<>"" Then CALL TxtBinInfo(TempSj,"d:\aa.txt")
'示 例:  Response.write "<form method='POST' action='test.asp'><input type='file' name='Tfile'><input type='submit' value='提交' name='B1'></form>"
'**************************************************''''
Public Function TxtBinInfo(ByVal Filestr,ByVal WebSvFile)
  TxtBinInfo=False
  DIM Wtempxx
  Wtempxx=""
  SET Tempsm = Server.CreateObject("ADODB.Stream")
  Tempsm.Mode=3
  Tempsm.Type=1
  Tempsm.Open
  Tempsm.LoadFromFile (Filestr)
  tempRedImg=Tempsm.Read
  for i = lenb(tempRedImg) to 1 step -1
      Wtempxx=Wtempxx& "地址号:" &i &"地址十六进制:"& Hex(ascb(midb(tempRedImg,i,1))) &"  十进制:"&ascb(midb(tempRedImg,i,1))&vbCrlf
  next
  Wtempxx=Wtempxx&vbCrlf&"大小:"&lenb(tempRedImg)&"字节 该文件名称为:" &Filestr
  Set M_fso = CreateObject("Scripting.FileSystemObject")
  Set FnameN= M_fso.OpenTextFile(WebSvFile,2,True)
  FnameN.Write Wtempxx
  FnameN.Close
  Set M_fso = Nothing
  Tempsm.Close
  SET Tempsm=nothing
  TxtBinInfo=True
End Function
'**************************************************''''
'函数ID:0030[将本地数据表或库上传并导入到服务器数据库的表中]
'函数名:ReadCdbToServ
'作 用:将本地数据表或库上传并导入到服务器数据库的表中
'参 数:CdbFileUp  ---- 被上传的库或表文件路径及文件名
'参 数:SdbConnStr ---- 服务器数据库链接字串
'参 数:SdbTbname  ---- 服务器将打开的表名
'参 数:FildStrArr ---- 导入的数据字段串(各字段用","隔开)
'返回值:成功返回 True 否则 False
'注可导入的文件类型有(0:Excel 1:Access 2:Text 3:DBF/FoxPro)
'注:Excel 的表为Sheet名称,文本及DBF/FoxPro的表名为数据文件的全名,如 aa.txt 或 aa.dbf
'注:Text 文本数据表是以","为分隔的格式 ,重点:被导入的数据库只能包含一个表,并且导入的字段应和服务器数据库的表相一致
'示 例:  CALL ReadCdbToServ(TempSj,"DRIVER=SQL Server;UID=sa;DATABASE=temp;SERVER=127.0.0.1;PWD=mzy1029;","img","mc,lx,mem")
'示 例:  Response.write "<form method='POST' action='test.asp' enctype='multipart/form-data'><input type='file' name='Tfile'><input type='submit' value='提交' name='B1'></form>"
'**************************************************''''
Public Function ReadCdbToServ(ByVal CdbFileUp,ByVal SdbConnStr,ByVal SdbTbname,ByVal FildStrArr)
  ReadCdbToServ=False
  Dim MbDir,Mbwjmc,aryTemp,VrCdb_Conn_Str,ofu_Conn,ofu_Rs,sfu_Conn,sfu_Rs,ofu_sql_str,sfu_sql_str,oaryTemp,TpTrs,Gtlx,CdbTbname
  VrCdb_Conn_Str=""
  MbDir=Readsyspath(1)
  If Right(MbDir,1)<>"\" Then MbDir=MbDir&"\"
  Mbwjmc=CdbFileUp
  aryTemp = Split(Mbwjmc,"\")
  Mbwjmc=aryTemp(UBound(aryTemp))
  aryTemp=Split(Mbwjmc,".")
  Gtlx=UCase(aryTemp(UBound(aryTemp)))
  If UpFsRn(100,MbDir,"temp."&Gtlx) Then
     If Gtlx="XLS" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="&MbDir&"temp."&Gtlx&";"             '' Excel [Tbname$]
     If Gtlx="MDB" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&"temp."&Gtlx&";Jet OLEDB:Database Password=;"              '' Access
     If Gtlx="TXT" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&";Extended Properties='text;HDR=Yes;FMT=Delimited'"        '' Text(,分割)
     If Gtlx="DBF" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&";Extended Properties=dBASE IV;User ID=Admin;Password="    '' DBF/FoxPro
     Set sfu_Conn=server.createobject("ADODB.Connection")
     Set sfu_Rs  =server.createobject("ADODB.Recordset")
     sfu_Conn.open SdbConnStr
     sfu_sql_str="select "&FildStrArr&" from "&SdbTbname
     Set ofu_Conn=server.createobject("ADODB.Connection")
     Set ofu_Rs  =server.createobject("ADODB.Recordset")
     ofu_Conn.open VrCdb_Conn_Str
     Set  TpTrs=ofu_Conn.OpenSchema(20)
     CdbTbname=TpTrs(2)
     TpTrs.Close
     Set TpTrs = Nothing
     If Gtlx="XLS" Then CdbTbname="["&CdbTbname&"]"
     ofu_sql_str="select "&FildStrArr&" from "&CdbTbname
     oaryTemp = Split(FildStrArr,",")
     sfu_Rs.open sfu_sql_str,sfu_Conn,1,3
     ofu_Rs.open ofu_sql_str,ofu_Conn,1,3
     Do While Not ofu_Rs.Eof
        sfu_Rs.addnew
        For i = LBound(oaryTemp) To UBound(oaryTemp)
            sfu_Rs(oaryTemp(i))=ofu_Rs(oaryTemp(i))
        Next
        sfu_Rs.update
        ofu_Rs.MoveNext
     Loop
     ofu_Rs.Close
     ofu_Conn.Close
     Set ofu_Rs = Nothing
     Set ofu_Conn=Nothing
     sfu_Rs.Close
     sfu_Conn.Close
     Set sfu_Rs = Nothing
     Set sfu_Conn=Nothing
     ReadCdbToServ=True
     DelFile(MbDir&"temp."&Gtlx)
  End If
End Function
'**************************************************
'函数ID:0031[返回服务器信息]
'函数名:GetServerInfo
'作 用:返回服务器信息
'参 数:Lx ---- 返回信息代码类
' 0 : 服务器的域名
' 1 : 服务器的IP地址
' 2 : 服务器操作系统
' 3 : 服务器解译引擎
' 4 : 服务器软件的名称及版本
' 5 : 服务器正在运行的端口
' 6 : 服务器CPU数量
' 7 : 服务器Application数量
' 8 : 服务器Session数量
' 9 : 请求的物理路径
'10 : 请求的URL
'11 : 服务器当前时间
'12 : 脚本连接超时时间
'13 : 服务器CPU详情
'14 :
'返回值:返回信息字串
'示 例:GetServerInfo(2)
'**************************************************
Public Function GetServerInfo(ByVal Lx)
  GetServerInfo=""
  Dim okCPUS, okCPU, okOS
  on error resume next
  Set WshShell = server.CreateObject("WScript.Shell")
  Set WshSysEnv = WshShell.Environment("SYSTEM")
  okOS = cstr(WshSysEnv("OS"))
  okCPUS = cstr(WshSysEnv("NUMBER_OF_PROCESSORS"))
  okCPU = cstr(WshSysEnv("PROCESSOR_IDENTIFIER"))
  if isnull(okCPUS) & "" = "" then
    okCPUS = Request.ServerVariables("NUMBER_OF_PROCESSORS")
  end if
  tnow = now():oknow = cstr(tnow)
  if oknow <> year(tnow) & "-" & month(tnow) & "-" & day(tnow) & " " & hour(tnow) & ":" & right(FormatNumber(minute(tnow)/100,2),2) & ":" & right(FormatNumber(second(tnow)/100,2),2) then oknow = oknow & " (日期格式不规范)"
  If Lx=0  Then GetServerInfo=Request.ServerVariables("server_name")
  If Lx=1  Then GetServerInfo=Request.ServerVariables("LOCAL_ADDR")
  If Lx=2  Then GetServerInfo=okOS     ''  Request.ServerVariables("OS")
  If Lx=3  Then GetServerInfo=ScriptEngine & "/"& ScriptEngineMajorVersion &"."&ScriptEngineMinorVersion&"."& ScriptEngineBuildVersion
  If Lx=4  Then GetServerInfo=Request.ServerVariables("SERVER_SOFTWARE")
  If Lx=5  Then GetServerInfo=Request.ServerVariables("server_port")
  If Lx=6  Then GetServerInfo=okCPUS   ''  Request.ServerVariables("NUMBER_OF_PROCESSORS")
  If Lx=7  Then GetServerInfo=Application.Contents.Count
  If Lx=8  Then GetServerInfo=Session.Contents.Count
  If Lx=9  Then GetServerInfo=Request.ServerVariables("path_translated")
  If Lx=10 Then GetServerInfo=Request.ServerVariables("server_name")&Request.ServerVariables("script_name")
  If Lx=11 Then GetServerInfo=oknow
  If Lx=12 Then GetServerInfo=Server.ScriptTimeout
  If Lx=13 Then GetServerInfo=okCPU
End Function
'**************************************************
'函数ID:0032[产生20位长度的唯一标识ID]
'函数名:MakeTheID
'作 用:产生20位长度的唯一标识ID
'参 数: ----
'返回值:返回20位长度的唯一标识ID
'示 例:MakeTheID()
'**************************************************
Public Function MakeTheID()
  DIM datestr,mytime,myyear,mymonth,myday,i
  myyear = cstr(year(date()))
  mymonth = cstr(month(date()))
  myday = cstr(day(date()))
  mymonth = lpad(mymonth,0,2)
  MakeTheID = myyear & "_" & mymonth & "_" & myday & "_"
  datestr=cstr(now())
  i = instr(datestr," ")
  mytime = right(datestr,len(datestr)-i)
  mytime = replace(mytime,":","_")
  randomize
  i = Int((9999 - 1000 + 1) * Rnd + 1000)
  MakeTheID = MakeTheID & mytime & "_" & i
  MakeTheID = replace(MakeTheID,"_","")
end function
'**************************************************
'函数ID:0033[用于左填充指定数量的字符,以达到规范长度]
'函数名:lpad
'作 用:用于左填充指定数量的字符,以达到规范长度
'参 数:desstr  ---- 目标字符
'参 数:padchar ---- 填充字符
'参 数:lenint  ---- 填充后的字符总长度
'返回值:返回字符
'示 例:response.write lpad(4,0,5),结果显示00004
'**************************************************
Public Function  lpad(ByVal desstr,ByVal padchar,ByVal lenint)
  dim d,p,t
  d = cstr(desstr)
  p = cstr(padchar)
  lpad=""
  for t=1 to lenint-len(d)
      lpad = p & lpad
  next
  lpad = lpad & d
end function
'**************************************************
'函数ID:0034[用于右填充指定数量的字符,以达到规范长度]
'函数名:rpad
'作 用:用于右填充指定数量的字符,以达到规范长度
'参 数:desstr  ---- 目标字符
'参 数:padchar ---- 填充字符
'参 数:lenint  ---- 填充后的字符总长度
'返回值:返回字符
'示 例:response.write rpad('a',0,5),结果显示a0000
'**************************************************
Public Function rpad(ByVal desstr,ByVal padchar,ByVal lenint)
  dim d,p,t
  d = cstr(desstr)
  p = cstr(padchar)
  rpad=""
  for t=1 to lenint-len(d)
      rpad = p & rpad 
  next
  rpad = d & rpad
end function
'**************************************************
'函数ID:0035[格式化时间(显示)]
'函数名:Format_Time
'作 用:格式化时间(显示)
'参 数:s_Time  ---- 时间变量
'参 数:n_Flag  ---- 时间样式类型代码
' 1:"yyyy-mm-dd hh:mm:ss"
' 2:"yyyy-mm-dd"
' 3:"hh:mm:ss"
' 4:"yyyy年mm月dd日"
' 5:"yyyymmdd"
' 6:"MM/DD"
'返回值:返回格式化后时间
'示 例:response.write Format_Time(now(),4)
'**************************************************
Public Function Format_Time(ByVal s_Time,ByVal n_Flag)
  Dim y, m, d, h, mi, s
  Format_Time = ""
  If IsDate(s_Time) = False Then Exit Function
  y = cstr(year(s_Time))
  m = cstr(month(s_Time))
  If len(m) = 1 Then m = "0" & m
  d = cstr(day(s_Time))
  If len(d) = 1 Then d = "0" & d
  h = cstr(hour(s_Time))
  If len(h) = 1 Then h = "0" & h
  mi = cstr(minute(s_Time))
  If len(mi) = 1 Then mi = "0" & mi
  s = cstr(second(s_Time))
  If len(s) = 1 Then s = "0" & s
  Select Case n_Flag
  Case 1
  ' yyyy-mm-dd hh:mm:ss
   Format_Time = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
  Case 2
  ' yyyy-mm-dd
   Format_Time = y & "-" & m & "-" & d
  Case 3
  ' hh:mm:ss
   Format_Time = h & ":" & mi & ":" & s
  Case 4
  ' yyyy年mm月dd日
   Format_Time = y & "年" & m & "月" & d & "日"
  Case 5
  ' yyyymmdd
   Format_Time = y & m & d
  Case 6
  'mm/dd
   Format_Time = m & "/" & d
  case 7
   Format_Time = m & "/" & d & "/" & right(y,2)
  End Select
End Function
'**************************************************
'函数ID:0036[测试数据库是否存在]
'函数名:TestDBOK
'作 用:测试数据库是否存在
'参 数:TestConnStr ---- 数据库链接字串
'返回值:测试成功返回 True 否则 False
'示 例:TestDBOK("testConnString")
'**************************************************
Public Function TestDBOK(ByVal TestConnStr)
  TestDBOK=False
  DIM fu_Conn
  Set fu_Conn=server.createobject("ADODB.Connection")
  On Error GoTo 0
  On Error Resume Next
  fu_Conn.open TestConnStr
  If Err.Number = 0 Then
     TestDBOK=True
  End If
  On Error GoTo 0
  Set fu_Conn = Nothing
End Function
'**************************************************
'函数ID:0037[测试数据库中的表是否存在]
'函数名:TestTbOK
'作 用:测试数据库中的表是否存在
'参 数:ObjConnName ---- 数据库链接定义
'参 数:TestDbname  ---- 被测试表的名称
'返回值:测试成功返回 True 否则 False
'示 例:TestTbOK(TestConn,"tbname")
'**************************************************
Public Function TestTbOK(ByVal ObjConnName,ByVal TestDbname)
  TestTbOK=False
  DIM fu_Rs
  Set fu_Rs=server.createobject("ADODB.Recordset")
  On Error GoTo 0
  On Error Resume Next
  fu_Rs.open "SELECT * FROM "&TestDbname,ObjConnName,1,1
  fu_Rs.Close
  If Err.Number = 0 Then
     TestTbOK=True
  End If
  On Error GoTo 0
  Set fu_Rs = Nothing
End Function
'**************************************************
'函数ID:0038[在线HTML编辑器]
'函数名:HTML_MZYEDIT
'作 用:测试数据库中的表是否存在
'参 数:MEIPath     ---- 各图标图像所在的路径
'参 数:GtimgPath   ---- 图片上传程序的URL
'参 数:GtswfPath   ---- Flash动画上传程序的URL
'参 数:GtwavPath   ---- 音乐文件上传程序的URL
'参 数:GtotherPath ---- 其他文件上传程序的URL
'返回值:HTML编辑器
'示 例:
'**************************************************
Public Function HTML_MZYEDIT(ByVal MEIPath,ByVal GtimgPath,ByVal GtswfPath,ByVal GtwavPath,ByVal GtotherPath)
  Response.Write "<!--BEGIN 史上最小的在线HTML编辑器,开发者:马政永,版本1.0 网站:http://www.lovemycn.com,本软件为授权使用,如没有马政永授权,任何人或单位不得使用,否则将已侵犯知识产权罪论处!-->" & vbCrlf
  Response.Write "<style>img{border: 1 solid #DFDED2;}</style>" & vbCrlf
  Response.Write "<table onConTextMenu ='event.returnValue=false;'  style='"">宋体; font-size: 9pt;cursor:default;width:100%;height:100%;' bgcolor='#DFDED2'><tr><td style='width:100%;height:0%;'>" & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='撤消' SRC='"&MEIPath&"undo.gif?http://www.xvna.com' NAME='Undo' ONCLICK='dojob(this.name);' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='恢复' SRC='"&MEIPath&"redo.gif?http://www.xvna.com' NAME='Redo' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='剪切' SRC='"&MEIPath&"cut.gif?http://www.xvna.com' NAME='Cut' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='拷贝' SRC='"&MEIPath&"copy.gif?http://www.xvna.com' NAME='Copy' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='粘贴' SRC='"&MEIPath&"paste.gif?http://www.xvna.com' NAME='Paste' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='删除' SRC='"&MEIPath&"delete.gif?http://www.xvna.com' NAME='Delete' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='距左' SRC='"&MEIPath&"aleft.gif?http://www.xvna.com' NAME='JustifyLeft' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='距中' SRC='"&MEIPath&"center.gif?http://www.xvna.com' NAME='JustifyCenter' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='距右' SRC='"&MEIPath&"aright.gif?http://www.xvna.com' NAME='JustifyRight' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' SRC='"&MEIPath&"fgs.gif?http://www.xvna.com'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='加粗' SRC='"&MEIPath&"bold.gif?http://www.xvna.com' NAME='Bold' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='斜体' SRC='"&MEIPath&"italic.gif?http://www.xvna.com' NAME='Italic' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='下划线' SRC='"&MEIPath&"underline.gif?http://www.xvna.com' NAME='Underline' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='超链' SRC='"&MEIPath&"wlink.gif?http://www.xvna.com' NAME='CreateLink' ONCLICK='dojob(this.name);' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='取消超链' SRC='"&MEIPath&"uwlink.gif?http://www.xvna.com' NAME='Unlink' ONCLICK='dojob(this.name);' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='取消格式' SRC='"&MEIPath&"untype.gif?http://www.xvna.com' NAME='RemoveFormat' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='水平线' SRC='"&MEIPath&"hr.gif?http://www.xvna.com' NAME='InsertHorizontalRule' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='缩进' SRC='"&MEIPath&"indent.gif?http://www.xvna.com' NAME='Indent' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='取消缩进' SRC='"&MEIPath&"outdent.gif?http://www.xvna.com' NAME='Outdent' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='数字标识' SRC='"&MEIPath&"numlist.gif?http://www.xvna.com' NAME='InsertOrderedList' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='点标识' SRC='"&MEIPath&"bullist.gif?http://www.xvna.com' NAME='InsertUnorderedList' ONCLICK='dojob(this.name);'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='加入图片' SRC='"&MEIPath&"img.gif?http://www.xvna.com' NAME='InsertImage' ONCLICK='inputimage();'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='加入FLASH' SRC='"&MEIPath&"intole.gif?http://www.xvna.com' NAME='Inputother' ONCLICK='inputother();'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='加入影音文件' SRC='"&MEIPath&"play.gif?http://www.xvna.com' NAME='Inputother' ONCLICK='inputotherpl();'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='加入文件链接' SRC='"&MEIPath&"otlin.gif?http://www.xvna.com' NAME='Inputother' ONCLICK='inputotlink();'  onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='插入Excel工作表' SRC='"&MEIPath&"excel.gif?http://www.xvna.com' NAME='excel' ONCLICK='inputexcel();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='去除Word格式' SRC='"&MEIPath&"wordtot.gif?http://www.xvna.com' NAME='wordtot' ONCLICK='wtohtm();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='转为TXT格式' SRC='"&MEIPath&"txt.gif?http://www.xvna.com' NAME='totxt' ONCLICK='atotxt();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='查看源码' SRC='"&MEIPath&"html.gif?http://www.xvna.com' NAME='edbh' ID='edbh' ONCLICK='htbhtxt();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf
  Response.Write "<IMG BORDER='0' ALT='在IE里预览' SRC='"&MEIPath&"view.gif?http://www.xvna.com' NAME='bh' ONCLICK='view();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();' >" & vbCrlf
  Response.Write "<IMG BORDER='0' SRC='"&MEIPath&"fgs.gif?http://www.xvna.com'> " & vbCrlf
  Response.Write "<SELECT NAME='FontName' STYLE='width:94;font-size: 9pt;cursor:default;' ONCHANGE='doadv(this.name,this[this.selectedIndex].value);this.selectedIndex=0;'>" & vbCrlf
  Response.Write "<OPTION SELECTED>字体</OPTION><OPTION VALUE='宋体'>宋体</OPTION><OPTION VALUE='黑体'>黑体</OPTION><OPTION VALUE='楷体_GB2312'>楷体</OPTION><OPTION VALUE='Arial'>Arial</OPTION><OPTION VALUE='Arial Black'>Arial Black</OPTION><OPTION VALUE='Wingdings'>Wingdings</OPTION>" & vbCrlf
  Response.Write "</SELECT><SELECT NAME='FontSize' STYLE='width:50;font-size: 9pt;cursor:default;' ONCHANGE='doadv(this.name,this[this.selectedIndex].value);this.selectedIndex=0;'>" & vbCrlf
  Response.Write "<OPTION SELECTED>字号</OPTION><OPTION VALUE='7'>一号</OPTION><OPTION VALUE='6'>二号</OPTION><OPTION VALUE='5'>三号</OPTION><OPTION VALUE='4'>四号</OPTION><OPTION VALUE='3'>五号</OPTION><OPTION VALUE='2'>六号</OPTION><OPTION VALUE='1'>七号</OPTION>" & vbCrlf
  Response.Write "</SELECT><SELECT NAME='ForeColor' STYLE='width:50;font-size: 9pt;cursor:default;' ONCHANGE='doadv(this.name,this[this.selectedIndex].value);this.selectedIndex=0;'>" & vbCrlf
  Response.Write "<OPTION SELECTED VALUE='#000000'>字色</OPTION><OPTION VALUE='#FFFFFF' STYLE='color:#FFFFFF'>●</OPTION><OPTION VALUE='#000000' STYLE='color:#000000'>●</OPTION><OPTION VALUE='#800000' STYLE='color:#800000'>●</OPTION><OPTION VALUE='#FF0000' STYLE='color:#FF0000'>●</OPTION><OPTION VALUE='#000080' STYLE='color:#000080'>●</OPTION>" & vbCrlf
  Response.Write "</SELECT><font color='#3D3D3D'> 表格[<INPUT TYPE='text' NAME='T_H' SIZE='3' VALUE='2' style='"">宋体; font-size: 9pt'>行<INPUT TYPE='text' NAME='T_L' SIZE='3' VALUE='2' style='"">宋体; font-size: 9pt'>列<INPUT TYPE='button' VALUE='插入' NAME='B1' ONCLICK='InsertOle(inputtable(T_H.value,T_L.value));' style='"">宋体; font-size: 9pt'>]</font>&nbsp;<IMG BORDER='0' SRC='"&MEIPath&"fgs.gif?http://www.xvna.com'>" & vbCrlf
  Response.Write "</td></tr><tr><td style='width:100%;height:100%;'>"
  Response.Write "<IFRAME SRC='about:blank' ID='MZYEDITWINDOW' style='width:100%;height:100%;'></IFRAME><div id='Temp_HTML' style='VISIBILITY: hidden; OVERFLOW: hidden; POSITION: absolute; WIDTH: 1px; HEIGHT: 1px'></div>" & vbCrlf
  Response.Write "</td></tr></table>" & vbCrlf
  Response.Write "<SCRIPT language='javascript'>" & vbCrlf
  Response.Write "var Htmlmode='Y';" & vbCrlf
  Response.Write "var Htmldata='';" & vbCrlf
  Response.Write "MZYEDITWINDOW.document.designMode='On';MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "var pjob;" & vbCrlf
  Response.Write "function mmoo()" & vbCrlf
  Response.Write "{pjob=(window.event.type).toUpperCase();" & vbCrlf
  Response.Write "if ((pjob=='MOUSEOVER') || (pjob=='MOUSEUP')){event.srcElement.style.borderLeft='1 solid #808080';" & vbCrlf
  Response.Write "event.srcElement.style.borderRight='1 solid #FFFFFF';" & vbCrlf
  Response.Write "event.srcElement.style.borderTop='1 solid #FFFFFF';" & vbCrlf
  Response.Write "event.srcElement.style.borderBottom='1 solid #808080';}" & vbCrlf
  Response.Write "if ((pjob=='MOUSEOUT') || (pjob=='MOUSEDOWN')){event.srcElement.style.border='1 solid #DFDED2';}" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function dojob(doname)" & vbCrlf
  Response.Write "{MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "ckmode();MZYEDITWINDOW.document.execCommand(doname);}" & vbCrlf
  Response.Write "function doadv(doname,jobtxt)" & vbCrlf
  Response.Write "{MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "ckmode();MZYEDITWINDOW.document.execCommand(doname,false,jobtxt);}" & vbCrlf
  Response.Write "function InsertOle(date)" & vbCrlf
  Response.Write "{ckmode();MZYEDITWINDOW.focus();MZYEDITWINDOW.document.selection.createRange().pasteHTML(date);}" & vbCrlf
  Response.Write "function htbhtxt()" & vbCrlf
  Response.Write "{MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "if (Htmlmode=='Y'){MZYEDITWINDOW.document.body.innerText=MZYEDITWINDOW.document.body.innerHTML;Htmlmode='N';edbh.alt='恢复HTML编辑状态';" & vbCrlf
  Response.Write "}else{MZYEDITWINDOW.document.body.innerHTML=MZYEDITWINDOW.document.body.innerText;Htmlmode='Y';edbh.alt='查看源码';}}" & vbCrlf
  Response.Write "function ckmode()" & vbCrlf
  Response.Write "{if (Htmlmode=='N'){MZYEDITWINDOW.document.body.innerHTML=MZYEDITWINDOW.document.body.innerText;Htmlmode='Y';}" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function view(){testwin=open('', 'testwin','status=no,menubar=no,toolbar=no,resizable=yes,scrollbars=yes');testwin.document.open();testwin.document.write(MZYEDITWINDOW.document.body.innerHTML);}" & vbCrlf
  Response.Write "function inputexcel(){s='<OBJECT id=Spreadsheet1 codeBase=file:\Bobsoftwareoffice2000msowc.cab height=250 width=100% classid=clsid:0002E510-0000-0000-C000-000000000046></OBJECT>';InsertOle(s);}" & vbCrlf
  Response.Write "function inputtable(h,l)" & vbCrlf
  Response.Write "{" & vbCrlf
  Response.Write "s='<table border=1 width=100% cellspacing=0 cellpadding=0>';" & vbCrlf
  Response.Write "for(i=1 ;i<=l;i++){s=s+'<tr>';for(j=1;j<=h;j++)s=s+'<td>&nbsp;</td>';s=s+'</tr>';}" & vbCrlf
  Response.Write "s=s+'</table>';" & vbCrlf
  Response.Write "return s;" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function inputimage()" & vbCrlf
  Response.Write "{" & vbCrlf
  Response.Write "var temp=showModalDialog('"&GtimgPath&"','', 'dialogWidth:30em; dialogHeight:26em; status:0');" & vbCrlf
  Response.Write "MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "if ((temp!==null) && (temp!==''))" & vbCrlf
  Response.Write "doadv('InsertImage',temp);" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function inputother()" & vbCrlf
  Response.Write "{" & vbCrlf
  Response.Write "var temp=showModalDialog('"&GtswfPath&"','', 'dialogWidth:30em; dialogHeight:26em;status:0');" & vbCrlf
  Response.Write "var tempa="&chr(34)&"<p align='center'><a onclick='MZYmovie.Play();' STYLE='cursor:hand;'>播放</a> <a onclick='MZYmovie.StopPlay();'  STYLE='cursor:hand;'>暂停</a> <a onclick=\"&chr(34)&"MZYmovie.width='600';MZYmovie.height='600';\"&chr(34)&"  STYLE='cursor:hand;'>最大化</a> <a onclick=\"&chr(34)&"MZYmovie.width='500';MZYmovie.height='400';\"&chr(34)&"  STYLE='cursor:hand;'>恢复</a><br><table NAME='FFWH' ID='FFWH'  border='0' width='100%' height='100%' cellspacing='0' cellpadding='0'><tr><td width='100%' height='90%' valign='middle' align='center'>"&chr(34)&";" & vbCrlf
  Response.Write "var tempb="&chr(34)&"<EMBED SRC='"&chr(34)&";" & vbCrlf
  Response.Write "var tempc="&chr(34)&"' WIDTH='500' HEIGHT='400' QUALITY='high' PLUGINSPAGE='http://www.macromedia.com/go/getflashplayer' TYPE='application/x-shockwave-flash' ID='MZYmovie' NAME='MZYmovie' MENU='false'>"&chr(34)&";" & vbCrlf
  Response.Write "var tempd="&chr(34)&"</td></tr></table></p>"&chr(34)&";" & vbCrlf
  Response.Write "MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "if ((temp!==null) && (temp!==''))" & vbCrlf
  Response.Write "temp=tempa+tempb+temp+tempc+tempd;" & vbCrlf
  Response.Write "InsertOle(temp);" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function inputotherpl()" & vbCrlf
  Response.Write "{" & vbCrlf
  Response.Write "var pl_w = prompt('录入影片的宽度', '100');" & vbCrlf
  Response.Write "var pl_h = prompt('录入影片的高度', '100');" & vbCrlf
  Response.Write "var tempwh="&chr(34)&"WIDTH="&chr(34)&"+pl_w+"&chr(34)&" HEIGHT="&chr(34)&"+pl_h;"
  Response.Write "var temp=showModalDialog('"&GtwavPath&"','', 'dialogWidth:30em; dialogHeight:26em; status:0');" & vbCrlf
  Response.Write "var temprma="&chr(34)&"<OBJECT CLASSID='clsid:CFCDAA03-8BE4-11CF-B84B-0020AFBBCCFA' ID='MZYMPL' "&chr(34)&";"
  Response.Write "var temprmb="&chr(34)&"><PARAM NAME='SRC' VALUE='"&chr(34)&";"
  Response.Write "var temprmc="&chr(34)&"'></OBJECT>"&chr(34)&";"
  Response.Write "var tempmpa="&chr(34)&"<OBJECT CLASSID='clsid:6BF52A52-394A-11D3-B153-00C04F79FAA6' ID='MZYMPL'"&chr(34)&";"
  Response.Write "var tempmpb="&chr(34)&"><PARAM NAME='URL' VALUE='"&chr(34)&";"
  Response.Write "var tempmpc="&chr(34)&"'></OBJECT>"&chr(34)&";"
  Response.Write "MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "if ((temp!==null) && (temp!==''))" & vbCrlf
  Response.write "var pllx = confirm('是否使用Windows media player?')"&vbCrlf
  Response.write "if (pllx != '0'){"&vbCrlf
  Response.Write "temp=tempmpa+'  '+tempwh+'  '+tempmpb+temp+tempmpc;"&vbCrlf
  Response.Write "}else{"&vbCrlf
  Response.Write "temp=temprma+'  '+tempwh+'  '+temprmb+temp+temprmc;"&vbCrlf
  Response.Write "}"&vbCrlf
  Response.Write "InsertOle(temp);" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function inputotlink()" & vbCrlf
  Response.Write "{" & vbCrlf
  Response.Write "var linkname = prompt('录入链接文字说明', '点这下载');" & vbCrlf
  Response.Write "var temp=showModalDialog('"&GtotherPath&"','', 'dialogWidth:30em; dialogHeight:26em; status:0');" & vbCrlf
  Response.Write "MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "if ((temp!==null) && (temp!=='')){" & vbCrlf
  Response.Write "temp="&chr(34)&"<a href="&chr(34)&"+temp+"&chr(34)&" _fcksavedurl=""&chr(34)&"+temp+"&chr(34)&"" _fcksavedurl=""&chr(34)&"+temp+"&chr(34)&"" _fcksavedurl=""&chr(34)&"+temp+"&chr(34)&"" target='_blank'>"&chr(34)&"+linkname+"&chr(34)&"</a>"&chr(34)&";" & vbCrlf
  Response.Write "InsertOle(temp);}" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function HTMLEncode(text){" & vbCrlf
  Response.Write "text = text.replace(/&/g, '&amp;') ;" & vbCrlf
  Response.Write "text = text.replace(/""/g, '&quot;') ;" & vbCrlf
  Response.Write "text = text.replace(/</g, '&lt;') ;" & vbCrlf
  Response.Write "text = text.replace(/>/g, '&gt;') ;" & vbCrlf
  Response.Write "text = text.replace(/'/g, '&#146;') ;" & vbCrlf
  Response.Write "text = text.replace(/\ /g,'&nbsp;');" & vbCrlf
  Response.Write "text = text.replace(/\n/g,'<br>');" & vbCrlf
  Response.Write "text = text.replace(/\t/g,'&nbsp;&nbsp;&nbsp;&nbsp;');" & vbCrlf
  Response.Write "return text;" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function cleanword(text) {" & vbCrlf
  Response.Write "text = text.replace(/<\/?SPAN[^>]*>/gi, '' );" & vbCrlf
  Response.Write "text = text.replace(/<(\w[^>]*) class=([^ |>]*)([^>]*)/gi, '<$1$3') ;" & vbCrlf
  Response.Write "text = text.replace(/<(\w[^>]*)([^""]*)""([^>]*)/gi, '<$1$3') ;" & vbCrlf
  Response.Write "text = text.replace(/<(\w[^>]*) lang=([^ |>]*)([^>]*)/gi, '<$1$3') ;" & vbCrlf
  Response.Write "text = text.replace(/<\\?\?xml[^>]*>/gi, '') ;" & vbCrlf
  Response.Write "text = text.replace(/<\/?\w+:[^>]*>/gi, '') ;" & vbCrlf
  Response.Write "text = text.replace(/&nbsp;/, ' ' );" & vbCrlf
  Response.Write "var re = new RegExp('(<P)([^>]*>.*?)(<\/P>)','gi') ;" & vbCrlf
  Response.Write "text = text.replace( re, '<div$2</div>' ) ;" & vbCrlf
  Response.Write "return text;" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "function atotxt()" & vbCrlf
  Response.Write "{if ( confirm('如果转为文本格式将丢失所有排版内容,请确认是否这样做?')){MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "MZYEDITWINDOW.document.body.innerHTML=HTMLEncode(MZYEDITWINDOW.document.body.innerText);}}" & vbCrlf
  Response.Write "function wtohtm()" & vbCrlf
  Response.Write "{if ( confirm('是否要将WORD格式去除?')){MZYEDITWINDOW.focus();" & vbCrlf
  Response.Write "MZYEDITWINDOW.document.body.innerHTML=cleanword(MZYEDITWINDOW.document.body.innerHTML);}}" & vbCrlf
  Response.Write "function CKjtb() {" & vbCrlf
  Response.Write "var oDiv = document.getElementById('Temp_HTML');" & vbCrlf
  Response.Write "oDiv.innerHTML = '' ;" & vbCrlf
  Response.Write "var oTextRange = document.body.createTextRange() ;" & vbCrlf
  Response.Write "oTextRange.moveToElementText(oDiv) ;" & vbCrlf
  Response.Write "oTextRange.execCommand('Paste') ;" & vbCrlf
  Response.Write "var sData = oDiv.innerHTML ;" & vbCrlf
  Response.Write "oDiv.innerHTML = '' ;" & vbCrlf
  Response.Write "var re = /<\w[^>]* class=""?MsoNormal""?/gi ; var nsData=sData;" & vbCrlf
  Response.Write "if ( re.test(sData)){" & vbCrlf
  Response.Write "if (confirm( '你要粘贴的内容好象是从Word中拷出来的,是否要先清除Word格式再粘贴?' )){" & vbCrlf
  Response.Write "nsData=cleanword(sData) ;" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "MZYEDITWINDOW.document.selection.createRange().pasteHTML(nsData);" & vbCrlf
  Response.Write "return false ;" & vbCrlf
  Response.Write "}" & vbCrlf
  Response.Write "setTimeout(""MZYEDITWINDOW.document.body.onpaste =CKjtb;"",1000);" & vbCrlf
  Response.Write "</SCRIPT>" & vbCrlf
  Response.Write "<!--END 史上最小的在线HTML编辑器,开发者:马政永,版本1.0 网站:http://www.lovemycn.com,本软件为授权使用,如没有马政永授权,任何人或单位不得使用,否则将已侵犯知识产权罪论处!-->" & vbCrlf
End Function
'**************************************************
'函数ID:0039[判断是否奇数]
'函数名:Is_JS
'作 用:判断是否奇数
'参 数:num  ---- 要判断的数
'返回值:返回True,否则False
'**************************************************
Public Function Is_JS(ByVal num)
  n=num mod 2
  if n=1 then
     Is_JS=true
  else
     Is_JS=false
  end if
end function
'**************************************************
'函数ID:0040[生成验证码图像BMP]
'函数名:GrapCode
'作 用:生成验证码图像
'参 数:MZYGCstr  ---- 要生成的图像的字符
'参 数:Noisy     ---- 噪点率(大于0的整数)
'参 数:BkColor   ---- 图案背景色(格式:R|G|B)
'参 数:FnColor   ---- 字符颜色(格式:R|G|B)
'参 数:NoColor   ---- 噪点颜色(格式:R|G|B)
'返回值:验证码图像
'示 例:Response.Write "<img src='" &GrapCode(Request("n"),6,"10|40|100","255|255|255","100|100|100")&"'>"
'**************************************************
Public Function GrapCode(ByVal MZYGCstr,ByVal Noisy,ByVal BkColor,ByVal FnColor,ByVal NoColor)
  If Len(Trim(MZYGCstr))>1 Then
  Dim imgsize,pimgsize
  Const cAmount = 36
  Const cCode = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  Dim ColorV(2)
  tmp=""
  tmp=Split(BkColor,"|")
  ColorV(0) =""
  For i = LBound(tmp) To UBound(tmp)
      ColorV(0) = ColorV(0) & ChrB(CInt(tmp(i)))
  Next
  tmp=""
  tmp=Split(FnColor,"|")
  ColorV(1) =""
  For i = LBound(tmp) To UBound(tmp)
      ColorV(1) = ColorV(1) & ChrB(CInt(tmp(i)))
  Next
  tmp=""
  tmp=Split(NoColor,"|")
  ColorV(2) =""
  For i = LBound(tmp) To UBound(tmp)
      ColorV(2) = ColorV(2) & ChrB(CInt(tmp(i)))
  Next
  imgsize=10*Len(MZYGCstr)*10*24/8
  pimgsize=10*Len(MZYGCstr)*10*24/8
  If Is_JS(Len(MZYGCstr)) Then
     imgsize=imgsize+74
     pimgsize=pimgsize+20
  Else
     imgsize=imgsize+54
  End If
  imgsize =Hex(imgsize)
  pimgsize=Hex(pimgsize)
  imgsize =Cstr(imgsize)
  pimgsize=Cstr(pimgsize)
  'dword对齐处理
  Dim length, byteCount,BytePatch
  length = Len(MZYGCstr)
  byteCount=((length*10*3) mod 4)
  If byteCount>0 Then
     byteCount= 4 - ((length*10*3) Mod 4)
     For i=1 To byteCount : BytePatch = BytePatch & chrB(00) : Next
  End If
  tmp=""
  For i=1 to len(imgsize) step 2
      If (i < len(imgsize)) Then
         tmp=tmp & Mid(imgsize,i,2) & "|"
      Else
         tmp=tmp & Mid(imgsize,i,2)
      End If
  Next
  imgsize=StrReverse(tmp)
  tmp=""
  tmp=Split(imgsize,"|")
  imgsize=""
  For i = 0 To 3
      If (i <= UBound(tmp)) Then
         imgsize=imgsize & ChrB("&H"&tmp(i))
      Else
         imgsize=imgsize & ChrB(0)
      End If
  Next
  ptmp=""
  For i=1 to len(pimgsize) step 2
      If (i < len(pimgsize)) Then
         ptmp=ptmp & Mid(pimgsize,i,2) & "|"
      Else
         ptmp=ptmp & Mid(pimgsize,i,2)
      End If
  Next
  pimgsize=StrReverse(ptmp)
  ptmp=""
  ptmp=Split(pimgsize,"|")
  pimgsize=""
  For i = 0 To 3
      If (i <= UBound(ptmp)) Then
         pimgsize=pimgsize & ChrB("&H"&ptmp(i))
      Else
         pimgsize=pimgsize & ChrB(0)
      End If
  Next
  MZYGCstr=UCase(MZYGCstr)
  tmp=""
  For i = 0 To (Len(MZYGCstr)-1)
      If i<>(Len(MZYGCstr)-1) Then
         tmp =tmp & InStr(cCode,Mid(MZYGCstr,i+1,1))-1 &"|"
      Else
         tmp =tmp & InStr(cCode,Mid(MZYGCstr,i+1,1))-1
      End If
  Next
  Dim vCode
  vCode=Split(tmp,"|")
  Response.Expires = -9999
  Response.AddHeader "pragma", "no-cache"
  Response.AddHeader "cache-ctrol", "no-cache"
  Response.Buffer = TRUE
  Response.ContentType="image/bmp"
  Response.Flush
  Response.BinaryWrite ChrB(66) & ChrB(77) & imgsize & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(54) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(40) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(10*Len(MZYGCstr)) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(12) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(1) & ChrB(0)
  Response.BinaryWrite ChrB(24) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & pimgsize & ChrB(18) & ChrB(11) & ChrB(0) & ChrB(0) & ChrB(18) & ChrB(11) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0) & ChrB(0)
  Dim NsD(35)
  NsD(0)  = "111111111111100001111101111011110111101111010010111101001011110100101111010010111101111011110111101111100001111111111111"
  NsD(1)  = "111111111111110111111100011111111101111111110111111111011111111101111111110111111111011111111101111111000001111111111111"
  NsD(2)  = "111111111111100001111101111011110111101111111110111111110111111110111111110111111110111111110111101111000000111111111111"
  NsD(3)  = "111111111111100001111101111011110111101111111101111111001111111111011111111110111101111011110111101111100001111111111111"
  NsD(4)  = "111111111111111011111111101111111100111111101011111101101111110110111111000000111111101111111110111111110000111111111111"
  NsD(5)  = "111111111111000000111101111111110111111111010001111100111011111111101111111110111101111011110111101111100001111111111111"
  NsD(6)  = "111111111111110001111110111011110111111111011111111101000111110011101111011110111101111011110111101111100001111111111111"
  NsD(7)  = "111111111111000000111101110111110111011111111011111111101111111101111111110111111111011111111101111111110111111111111111"
  NsD(8)  = "111111111111100001111101111011110111101111011110111110000111111011011111011110111101111011110111101111100001111111111111"
  NsD(9)  = "111111111111100011111101110111110111101111011110111101110011111000101111111110111111111011110111011111100011111111111111"
  NsD(10) = "111111111111110111111111011111111010111111101011111110101111111010111111000001111101110111110111011110001000111111111111"
  NsD(11) = "111111111110000001111101111011110111101111011101111100001111110111011111011110111101111011110111101110000001111111111111"
  NsD(12) = "111111111111100000111101111011101111101110111111111011111111101111111110111111111011111011110111011111100011111111111111"
  NsD(13) = "111111111110000011111101110111110111101111011110111101111011110111101111011110111101111011110111011110000011111111111111"
  NsD(14) = "111111111110000001111101111011110110111111011011111100001111110110111111011011111101111111110111101110000001111111111111"
  NsD(15) = "111111111110000001111101111011110110111111011011111100001111110110111111011011111101111111110111111110001111111111111111"
  NsD(16) = "111111111111100001111101110111101111011110111111111011111111101111111110111000111011110111110111011111100011111111111111"
  NsD(17) = "111111111110001000111101110111110111011111011101111100000111110111011111011101111101110111110111011110001000111111111111"
  NsD(18) = "111111111111000001111111011111111101111111110111111111011111111101111111110111111111011111111101111111000001111111111111"
  NsD(19) = "111111111111100000111111101111111110111111111011111111101111111110111111111011111111101111101110111110000111111111111111"
  NsD(20) = "111111111110001000111101110111110110111111010111111100011111110101111111011011111101101111110111011110001000111111111111"
  NsD(21) = "111111111110001111111101111111110111111111011111111101111111110111111111011111111101111111110111101110000000111111111111"
  NsD(22) = "111111111110001000111100100111110010011111001001111101010111110101011111010101111101010111110101011110010100111111111111"
  NsD(23) = "111111111110001000111100110111110011011111010101111101010111110101011111011001111101100111110110011110001101111111111111"
  NsD(24) = "111111111111100011111101110111101111101110111110111011111011101111101110111110111011111011110111011111100011111111111111"
  NsD(25) = "111111111110000001111101111011110111101111011110111100000111110111111111011111111101111111110111111110001111111111111111"
  NsD(26) = "111111111111100011111101110111101111101110111110111011111011101111101110111110111010011011110110011111100010111111111111"
  NsD(27) = "111111111110000011111101110111110111011111011101111100001111110101111111011011111101101111110111011110001100111111111111"
  NsD(28) = "111111111111100000111101111011110111101111011111111110011111111110011111111110111101111011110111101111000001111111111111"
  NsD(29) = "111111111110000000111011011011111101111111110111111111011111111101111111110111111111011111111101111111100011111111111111"
  NsD(30) = "111111111110001000111101110111110111011111011101111101110111110111011111011101111101110111110111011111100011111111111111"
  NsD(31) = "111111111110001000111101110111110111011111011101111110101111111010111111101011111110101111111101111111110111111111111111"
  NsD(32) = "111111111110010100111101010111110101011111010101111101010111110010011111101011111110101111111010111111101011111111111111"
  NsD(33) = "111111111110001000111101110111111010111111101011111111011111111101111111101011111110101111110111011110001000111111111111"
  NsD(34) = "111111111110001000111101110111110111011111101011111110101111111101111111110111111111011111111101111111100011111111111111"
  NsD(35) = "111111111111000000111101110111111111011111111011111111101111111101111111110111111110111111111011101111000000111111111111"
  Dim a,b,c
  For a=11 to 0 Step -1
      For c=0 to UBound(vCode)
          For b=1 to 10
              If Rnd * 99 + 1 < Noisy Then
                 Response.BinaryWrite ColorV(2)
              Else
                 Response.BinaryWrite ColorV(Mid(NsD(CInt(vCode(c))),a*10+b,1))
              End If
          Next
      Next
      If byteCount>0 Then Response.BinaryWrite BytePatch
  Next
  End If
End Function
'**************************************************
'函数ID:0041[生成随机密码]
'函数名:MakeRndPass
'作 用:生成随机密码
'参 数:passlen  ---- 要生成的密码长度
'参 数:passtype ---- 要生成的密码类型
'返回值:验证生成的随机密码
'类型解释:
'passfull       (所在可用字符 如“90!@#$%”)
'passnumber     (纯数字)
'passspecial    (非常用字符)
'passCharNumber (所有字母及数字)
'passUpperCharNumber (大写字母数字)
'passLowerCharNumber (小写字母数字)
'passChar       (所有大小写字母)
'passUpperChar  (所有大写字母)
'passLowerChar  (所有小写字母)
'示 例:MakeRndPass(4,"passUpperCharNumber")
'**************************************************
Public Function MakeRndPass(ByVal passlen,ByVal passtype)
  dim passFull,passNumber,passSpecial,passCharNumber,passChar,pass,passUpperCharNumber,passLowerCharNumber,passUpperChar,passLowerChar,ii,jj
  passFull = "1234567890!@#$%^&*()[];',./{}:?`~-=\_+|abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
  passNumber = "1234567890"
  passSpecial = "!@#$%^&*()[];',./{}:?`~-=\_+|"
  passCharNumber = "abcdefghijklmnopqrstuvwxyz1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  passUpperCharNumber = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  passLowerCharNumber = "abcdefghijklmnopqrstuvwxyz1234567890"
  passChar = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
  passUpperChar = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  passLowerChar = "abcdefghijklmnopqrstuvwxyz"
  select case lcase(trim(passType))
  case "passfull"
        pass = passFull
  case "passnumber"
        pass = passNumber
  case "passspecial"
        pass = passSpecial
  case "passcharnumber"
        pass = passCharNumber
  case "passchar"
        pass = passChar
  case "passupperchar"
        pass = passUpperChar
  case "passlowerchar"
        pass = passLowerChar
  case "passuppercharnumber"
        pass = passUpperCharNumber
  case "passlowercharnumber"
        pass = passLowerCharNumber
  case else
        pass = passlowercharnumber
  end select
  makeRndPass=""
  for ii=1 to cint(passlen)
      randomize
      jj = int(rnd()*len(pass)+1)
      makeRndPass = cstr(makeRndPass) & mid(pass,jj,1)
  next
End Function
'**************************************************
'函数ID:0042[字符加解密]
'函数名:addmw
'作 用:字符加解密
'参 数:nyw  ---- 被加密的字符
'返回值:加密后的字符
'示 例:
'**************************************************
Public Function addmw(ByVal nyw)
  addmw=""
  On Error GoTo 0
  On Error Resume Next
  rndChararray = "abcdefghijklmnopqrstuvwxyz1234567890"
  randomize
  keya=Mid(rndChararray,int(rnd()*35)+1,1)
  keyb=Mid(rndChararray,int(rnd()*35)+1,1)
  temp=""
  newStr=""
  For i=1 to len(nyw)
      temp=Mid(nyw,i,1)
      bLowChr=AscB(MidB(temp, 1, 1)) Xor asc(keya)
      bHigChr=AscB(MidB(temp, 2, 1)) Xor asc(keyb)
      newStr=newStr & ChrB(bLowChr) & ChrB(bHigChr)
  Next
  bLowChr=AscB(MidB(keyb, 1, 1)) Xor 100
  bHigChr=AscB(MidB(keyb, 2, 1)) Xor 20
  keyb=ChrB(bLowChr) & ChrB(bHigChr)
  bLowChr=AscB(MidB(keya, 1, 1)) Xor 128
  bHigChr=AscB(MidB(keya, 2, 1)) Xor 18
  keya=ChrB(bLowChr) & ChrB(bHigChr)
  newStr=keyb & keya & StrReverse(newStr)
  If Err.Number = 0 Then
       addmw=CodeCookie(newStr)
  End If
  On Error GoTo 0
End Function
'**************************************************
'函数ID:0043[解密字符加解密]
'函数名:exmw
'作 用:解密字符加解密
'参 数:nmw  ---- 加密的字符
'返回值:解密加密后的字符
'示 例:
'**************************************************
Public Function exmw(ByVal nmw)
  exmw=""
  On Error GoTo 0
  On Error Resume Next
  Dim keya,keyb,newStr,temp
  nmw=DecodeCookie(nmw)
  keya=Mid(nmw,2,1)
  keyb=Mid(nmw,1,1)
  bLowChr=ChrB(AscB(MidB(keya, 1, 1)) Xor 128)
  bHigChr=ChrB(AscB(MidB(keya, 2, 1)) Xor 18)
  keya=bLowChr & bHigChr
  bLowChr=ChrB(AscB(MidB(keyb, 1, 1)) Xor 100)
  bHigChr=ChrB(AscB(MidB(keyb, 2, 1)) Xor 20)
  keyb=bLowChr & bHigChr
  Str=StrReverse(Mid(nmw,3,len(nmw)))
  newStr=""
  temp=""
  For i=1 to len(Str)
      temp=Mid(Str,i,1)
      bLowChr=AscB(MidB(temp, 1, 1)) Xor asc(keya)
      bHigChr=AscB(MidB(temp, 2, 1)) Xor asc(keyb)
      newStr=newStr & ChrB(bLowChr) & ChrB(bHigChr)
  Next
  If Err.Number = 0 Then
       exmw=newStr
  End If
  On Error GoTo 0
End Function
'**************************************************
'函数ID:0044[创建数据表]
'函数名:CreatTable
'作 用:创建数据表
'参 数:ConnStrs    ---- 数据库链接字串
'参 数:Tabnamestr  ---- 数据表名称
'参 数:CvArrstr    ---- 字段表 (写法: Fname1#Type#Len#Defvalue|Fname1#Type#Len#Defvalue|...) 最后一个不要写“|”
'参 数:SqlType     ---- Sql语句类型 (0 Access 1 Mssqlserver)
' Fname,Type,Len,Defvalue 说明:字段名称,字段类型,字段长度,默认值
'字段类型 Type C/c 字符 T/t 文本 I/i 二进制 D/d 日期 M/m 关键字(字符型) A/a 关键字自动编号(数值型) N/n 数值(float) Z/z 数值(int)
'返回值:如果建立成功返回 True 否则 False
'示 例:CreatTable(basicDB(3),"cs","fa#t##|fb#c#20#a|fc#n##5",0)
'**************************************************
Public Function CreatTable(ByVal ConnStrs,ByVal Tabnamestr,ByVal CvArrstr,ByVal SqlType)
  CreatTable=False
  On Error GoTo 0
  On Error Resume Next
  Dim filsarry,NeFilarry,Filstr,spfstr,templx,def_kh_l,def_kh_r,TempSqlStr
  def_kh_l=""
  def_kh_r=""
  Filstr=""
  spfstr=""
  TempSqlStr=""
  filsarry=Split(CvArrstr,"|")
  For ai = LBound(filsarry) To UBound(filsarry)
      NeFilarry=Split(filsarry(ai),"#")
      templx=""
      If UCase(NeFilarry(1))="C" Then templx="varchar(" & NeFilarry(2) & ")"
      If UCase(NeFilarry(1))="T" Then templx="TEXT"
      If UCase(NeFilarry(1))="I" Then templx="image"
      If UCase(NeFilarry(1))="D" Then templx="datetime"
      If UCase(NeFilarry(1))="M" Then templx="varchar(" & NeFilarry(2) & ") NOT NULL PRIMARY KEY"
      If UCase(NeFilarry(1))="A" Then templx="Int IDENTITY (1,1) NOT NULL PRIMARY KEY"
      If UCase(NeFilarry(1))="N" Then templx="Float"
      If UCase(NeFilarry(1))="Z" Then templx="Int"
      If SqlType =1 Then
         def_kh_l="('"
         def_kh_r="')"
      End If
      If Trim(NeFilarry(3))<>"" Then templx=templx &" DEFAULT " & def_kh_l & Trim(NeFilarry(3)) & def_kh_r
      If ai<>UBound(filsarry) Then
         spfstr= spfstr & "[" & NeFilarry(0) & "] " & templx &","
      Else
         spfstr= spfstr & "[" & NeFilarry(0) & "] " & templx
      End If
  Next
  TempSqlStr="CREATE TABLE ["&Trim(Tabnamestr)&"] (" & spfstr & ")"
  set fu_Conn=server.createobject("ADODB.Connection")
  fu_Conn.open ConnStrs
  fu_Conn.Execute TempSqlStr
  fu_Conn.Close
  Set fu_Conn=Nothing
  If Err.Number = 0 Then
     CreatTable=True
  End If
  On Error GoTo 0
End Function
'**************************************************
'函数ID:0045[在数据库中插入字段值]
'函数名:InterTbValue
'作 用:创建数据表
'参 数:ConnStrs    ---- 数据库链接字串
'参 数:Tabnamestr  ---- 数据表名称
'参 数:CvArrstr    ---- 字段表 (写法: Fname1#Value|Fname2#Value|...) 最后一个不要写“|”
'参 数:SqlType     ---- Sql语句类型 (0 Access 1 Mssqlserver)
' Fname,Value 说明:字段名称,字段值
'返回值:如果插入成功返回 True 否则 False
'示 例:InterTbValue(basicDB(3),"cs","fa#t|fb#c|fc#n#")
'**************************************************
Public Function InterTbValue(ByVal ConnStrs,ByVal Tabnamestr,ByVal CvArrstr,ByVal SqlType)
  InterTbValue=False
  On Error GoTo 0
  On Error Resume Next
  Dim def_kh_l,def_kh_r,Filarray,Valuearray,Temparraya,Temparrayb,TempSqlStr1
  def_kh_l  =""
  def_kh_r  =""
  Temparraya=Split(CvArrstr,"|")
  For fai = LBound(Temparraya) To UBound(Temparraya)
      Temparrayb=Split(Temparraya(fai),"#")
      If (fai<> UBound(Temparraya)) Then
         Filarray  =Filarray & "[" & Temparrayb(0) & "],"
         Valuearray=Valuearray & "'" & Temparrayb(1) & "',"
      Else
         Filarray  =Filarray & "[" & Temparrayb(0) & "]"
         Valuearray=Valuearray & "'" & Temparrayb(1) & "'"
      End If
  Next
  TempSqlStr1="INSERT INTO [" & Tabnamestr & "] (" & Filarray & ") VALUES (" & Valuearray & ")"
  set fu1_Conn=server.createobject("ADODB.Connection")
  fu1_Conn.open ConnStrs
  fu1_Conn.Execute TempSqlStr1
  fu1_Conn.Close
  Set fu1_Conn=Nothing
  If Err.Number = 0 Then
     InterTbValue=True
  End If
  On Error GoTo 0
End Function
'**************************************************
'函数ID:0046[Cookie防乱码写入时用]
'函数名:CodeCookie
'作 用:Cookie防乱码写入时用
'参 数:str  ---- 字符串
'返回值:整理后的字符串
'示 例:
'**************************************************
Public Function CodeCookie(str)
  If isNumeric(str) Then str=Cstr(str)
  Dim newstr
  newstr=""
  For i=1 To Len(str)
      newstr=newstr & ascw(mid(str,i,1))
      If i<> Len(str) Then newstr= newstr & "a"
  Next
  CodeCookie=newstr
End Function
'**************************************************
'函数ID:0047[Cookie防乱码读出时用]
'函数名:DecodeCookie
'作 用:Cookie防乱码读出时用
'参 数:str  ---- 字符串
'返回值:整理后的字符串
'示 例:
'**************************************************
Public Function DecodeCookie(str)
  DecodeCookie=""
  Dim newstr
  newstr=Split(str,"a")
  For i = LBound(newstr) To UBound(newstr)
      DecodeCookie= DecodeCookie & chrw(newstr(i))
  Next
End Function
'**************************************************
'函数ID:0048[检测用户名和密码是否正确]
'函数名:DecodeCookie
'作 用:检测用户名和密码是否正确
'参 数:ConnStrs    ---- 数据库链接字串
'参 数:Tabnamestr  ---- 数据表名称
'参 数:Tumc        ---- 用户名称字段名称
'参 数:Cumc        ---- 用户名称
'参 数:TCumm       ---- 用户密码字段名称
'参 数:Cumm        ---- 用户密码
'参 数:TUid        ---- 用户ID(标识)字段名称
'返回值:检测成功返回 用户ID 否则 空字符串
'示 例:
'**************************************************
Public Function CKUSMCMM(ByVal ConnStrs,ByVal Tabnamestr,ByVal Tumc,ByVal Cumc,ByVal Tumm,ByVal Cumm,ByVal TUid)
  CKUSMCMM=""
  On Error GoTo 0
  On Error Resume Next
  Set sfu_Conn=server.createobject("ADODB.Connection")
  Set sfu_Rs  =server.createobject("ADODB.Recordset")
  sfu_Conn.open ConnStrs
  sfu_sql_str="select " & TUid & "," & Tumc & "," & Tumm & " from " & Tabnamestr
  sfu_Rs.open sfu_sql_str,sfu_Conn,1,1
  If sfu_Rs.RecordCount >0 Then
     Do While Not sfu_Rs.Eof
        If (sfu_Rs(Tumc)=Cumc) AND (exmw(sfu_Rs(Tumm))=Cumm) Then
           CKUSMCMM=sfu_Rs(TUid)
           Exit Do
        End If
        sfu_Rs.MoveNext
     Loop
  End If
  sfu_Rs.Close
  sfu_Conn.Close
  Set sfu_Rs = Nothing
  Set sfu_Conn=Nothing
  On Error GoTo 0
End Function
'**************************************************
'函数ID:0049[生成时间的整数]
'函数名:GetMyTimeNumber()
'作 用:生成时间的整数
'参 数:lx  ---- 时间整数的类型
' lx=0 到分钟 lx=1 到小时 lx=2 到天 lx=3 到月
'返回值:生成时间的整数值(最小到分钟)
'示 例:
'**************************************************
Public Function GetMyTimeNumber(lx)
  If lx=0 Then GetMyTimeNumber=Year(Date)*12*30*24*60+Month(Date)*30*24*60+Day(Date)*24*60+Hour(Time)*60+Minute(Time)
  If lx=1 Then GetMyTimeNumber=Year(Date)*12*30*24+Month(Date)*30*24+Day(Date)*24+Hour(Time)
  If lx=2 Then GetMyTimeNumber=Year(Date)*12*30+Month(Date)*30+Day(Date)
  If lx=3 Then GetMyTimeNumber=Year(Date)*12+Month(Date)
End Function
'**************************************************
'函数ID:0050[获得栏目的所有子栏目字符串并用","隔开]
'函数名:GTLMfunLM
'作 用:获得栏目的所有子栏目字符串并用","隔开
'参 数:LMid          ---- 栏目代码
'参 数:ConnStrArray  ---- 栏目数据链接串
'返回值:子栏目字符串并用","隔开
'示 例:hh="数据表链接字串|父栏目字段名|栏目字段名|表名"
'示 例:GTLMfunLM(22,basicDB(3) & "|FTitId|TitId|TITS")
'**************************************************
Public Function GTLMfunLM(ByVal LMid,ByVal ConnStrArray)
  Dim LMstrxx,zdbz,Nlm
  zdbz=False
  LMstrxx=""
  aTempstr=GTLMfunLM_whil(LMid,ConnStrArray)
  LMstrxx=LMstrxx & aTempstr
  If InStrRev(aTempstr,",") > 0 Then
     Do While Not zdbz
        bTempstr=GTLMfunLM_Fj(aTempstr,ConnStrArray)
        LMstrxx=LMstrxx & bTempstr
        If bTempstr="" Then zdbz=True
        aTempstr=bTempstr
     Loop
  Else
     LMstrxx=aTempstr
  End If
  LMstrxx=Trim(LMstrxx)
  If LMstrxx<>"" Then If Mid(LMstrxx,Len(LMstrxx),1) = ","  Then LMstrxx=Mid(LMstrxx,1,Len(LMstrxx)-1)
  GTLMfunLM=LMstrxx
End Function
Public Function GTLMfunLM_whil(ByVal LMidstr,ByVal ConnStrArray)
  ppTemp=Split(ConnStrArray,"|")
  GTLMfunLM_whil=""
  Set telm_Conn=server.createobject("ADODB.Connection")
  Set telm_Rs  =server.createobject("ADODB.Recordset")
  telm_Conn.open ppTemp(0)
  telm_sql_str="SELECT " & ppTemp(1) & "," & ppTemp(2) & " FROM " & ppTemp(3) & " WHERE (" & ppTemp(1) & "='" & LMidstr & "')"
  telm_Rs.open telm_sql_str,telm_Conn,1,1
  If telm_Rs.RecordCount >0 Then
     Do While Not telm_Rs.Eof
        GTLMfunLM_whil=GTLMfunLM_whil & Trim(telm_Rs(ppTemp(2))) & ","
        telm_Rs.MoveNext
     Loop
  End If
  telm_Rs.Close
  telm_Conn.Close
  Set telm_Rs = Nothing
  Set telm_Conn=Nothing
End Function
Public Function GTLMfunLM_Fj(ByVal str,ByVal ConnStrArray)
  Dim templjid
  templjid=""
  If Trim(str)<>"" Then
     fjTemp=Split(str,",")
     For i = LBound(fjTemp) To UBound(fjTemp)
         If Trim(fjTemp(i))<>"" Then
            templjid=templjid & GTLMfunLM_whil(fjTemp(i),ConnStrArray)
         End If
     Next
  End If
  GTLMfunLM_Fj=templjid
End Function

%>
 

相关内容
赞助商链接