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

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

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

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

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 & "|"

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 & "|"

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,"")

strContent=objReg.Replace(strContent,"")

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 "<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=" "

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 "</tr>" & vbCrlf

End If

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();'>  <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))

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

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: 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))

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))

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))

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

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))

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

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

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 "" & 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' 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' 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' 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' 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' 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' 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' 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' 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' NAME='JustifyRight' ONCLICK='dojob(this.name);' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' SRC='"&MEIPath&"fgs.gif'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='加粗' SRC='"&MEIPath&"bold.gif' 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' 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' 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' 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' 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' 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' 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' 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' 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' 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' 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' NAME='InsertImage' ONCLICK='inputimage();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='加入FLASH' SRC='"&MEIPath&"intole.gif' NAME='Inputother' ONCLICK='inputother();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='加入影音文件' SRC='"&MEIPath&"play.gif' NAME='Inputother' ONCLICK='inputotherpl();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='加入文件链接' SRC='"&MEIPath&"otlin.gif' NAME='Inputother' ONCLICK='inputotlink();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='插入Excel工作表' SRC='"&MEIPath&"excel.gif' NAME='excel' ONCLICK='inputexcel();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='去除Word格式' SRC='"&MEIPath&"wordtot.gif' NAME='wordtot' ONCLICK='wtohtm();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='转为TXT格式' SRC='"&MEIPath&"txt.gif' NAME='totxt' ONCLICK='atotxt();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();'> " & vbCrlf

Response.Write "<IMG BORDER='0' ALT='查看源码' SRC='"&MEIPath&"html.gif' 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' NAME='bh' ONCLICK='view();' onmouseout='mmoo();' onmouseover='mmoo();' onmousedown='mmoo();' onmouseup='mmoo();' >" & vbCrlf

Response.Write "<IMG BORDER='0' SRC='"&MEIPath&"fgs.gif'> " & 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> <IMG BORDER='0' SRC='"&MEIPath&"fgs.gif'>" & 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> </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, '&') ;" & vbCrlf

Response.Write "text = text.replace(/""/g, '"') ;" & vbCrlf

Response.Write "text = text.replace(/</g, '<') ;" & vbCrlf

Response.Write "text = text.replace(/>/g, '>') ;" & vbCrlf

Response.Write "text = text.replace(/'/g, '') ;" & vbCrlf

Response.Write "text = text.replace(/\ /g,' ');" & vbCrlf

Response.Write "text = text.replace(/\n/g,'<br>');" & vbCrlf

Response.Write "text = text.replace(/\t/g,'    ');" & 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(/<]*/gi"\\?\?xml[^>]*>/gi, '') ;" & vbCrlf

Response.Write "text = text.replace(/<\/?\w+:[^>]*>/gi, '') ;" & vbCrlf

Response.Write "text = text.replace(/ /, ' ' );" & 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 "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 "" & 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)))

tmp=""

tmp=Split(FnColor,"|")

ColorV(1) =""

For i = LBound(tmp) To UBound(tmp)

ColorV(1) = ColorV(1) & ChrB(CInt(tmp(i)))

tmp=""

tmp=Split(NoColor,"|")

ColorV(2) =""

For i = LBound(tmp) To UBound(tmp)

ColorV(2) = ColorV(2) & ChrB(CInt(tmp(i)))

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

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

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

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

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

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

If byteCount>0 Then Response.BinaryWrite BytePatch

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)

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)

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)

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

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

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"

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))

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

GTLMfunLM_Fj=templjid

End Function