马政永作的标准ASP应用函数库

来源：百度文库编辑：神马文学网时间：2024/04/27 13:54:32

原始函数文链接下载地址为:www.lovemycn.com/index.asp?job=vn&id=200606132019599558
<%
‘‘‘‘===============================================‘‘‘‘
‘‘‘‘ 函数制作说明 ‘‘‘‘
‘‘‘‘ 本函数库作者：马政永，内蒙古阿拉善 ‘‘‘‘
‘‘‘‘作者主页：www.lovemycn.com or als.lovemycn.com ‘‘‘‘
‘‘‘‘作者邮箱：mzymcm@yahoo.com.cn Phone:13947490036‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ 本函数免费提供使用，但不要去版权信息 ‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ 本函数库还在丰富中，多谢支持 ‘‘‘‘
‘‘‘‘-----------------------------------------------‘‘‘‘
‘‘‘‘===============================================‘‘‘‘
‘‘‘‘ 函数目录 ‘‘‘‘
‘‘‘‘-----------------------------------------------‘‘‘‘
‘‘‘‘ 函数ID：0001[截字符串] ‘‘‘‘
‘‘‘‘ 函数ID：0002[过滤html] ‘‘‘‘
‘‘‘‘ 函数ID：0003[打开任意数据表并显示表结构及内容]‘‘‘‘
‘‘‘‘ 函数ID：0004[读取两种路径] ‘‘‘‘
‘‘‘‘ 函数ID：0005[测试某个文件存在否] ‘‘‘‘
‘‘‘‘ 函数ID：0006[删除某个文件] ‘‘‘‘
‘‘‘‘ 函数ID：0007[判断目录是否存在] ‘‘‘‘
‘‘‘‘ 函数ID：0008[创建目录] ‘‘‘‘
‘‘‘‘ 函数ID：0009[删除目录] ‘‘‘‘
‘‘‘‘ 函数ID：0010[指定目录的文件列表] ‘‘‘‘
‘‘‘‘ 函数ID：0011[指定目录的目录列表] ‘‘‘‘
‘‘‘‘ 函数ID：0012[创建文本文件] ‘‘‘‘
‘‘‘‘ 函数ID：0013[读取文本文件] ‘‘‘‘
‘‘‘‘ 函数ID：0014[检测ID是否为数字类型] ‘‘‘‘
‘‘‘‘ 函数ID：0015[正则表达式测试] ‘‘‘‘
‘‘‘‘ 函数ID：0016[获得执行程序的名称] ‘‘‘‘
‘‘‘‘ 函数ID：0017[读取用户IP地址信息] ‘‘‘‘
‘‘‘‘ 函数ID：0018[上传文件到指定目录并改文件名称] ‘‘‘‘
‘‘‘‘ 函数ID：0019[过滤HTML脚本] ‘‘‘‘
‘‘‘‘ 函数ID：0020[创建MsAccess数据库] ‘‘‘‘
‘‘‘‘ 函数ID：0021[创建MsSQLServer数据库] ‘‘‘‘
‘‘‘‘ 函数ID：0022[通过JMAIL发信] ‘‘‘‘
‘‘‘‘ 函数ID：0023[测试组件是否安装] ‘‘‘‘
‘‘‘‘ 函数ID：0024[上传文件的窗口] ‘‘‘‘
‘‘‘‘ 函数ID：0025[取得数据库链接字串] ‘‘‘‘
‘‘‘‘ 函数ID：0026[取得multipart/form-data形式上传文件]
‘‘‘‘ 函数ID：0027[保存或查看上传到数据库中的数据，带调用上传窗口]
‘‘‘‘ 函数ID：0028[取得图像的类型|宽|高] ‘‘‘‘
‘‘‘‘ 函数ID：0029[将本地文件进行二进制分析，并保存到服务器的指定目录下]
‘‘‘‘ 函数ID：0030[将本地数据表或库上传并导入到服务器数据库的表中]
‘‘‘‘ 函数ID：0031[返回服务器信息] ‘‘‘‘
‘‘‘‘ 函数ID：0032[产生20位长度的唯一标识ID] ‘‘‘‘
‘‘‘‘ 函数ID：0033[用于左填充指定数量的字符] ‘‘‘‘
‘‘‘‘ 函数ID：0034[用于右填充指定数量的字符] ‘‘‘‘
‘‘‘‘ 函数ID：0035[格式化时间(显示)] ‘‘‘‘
‘‘‘‘ 函数ID：0036[测试数据库是否存在] ‘‘‘‘
‘‘‘‘ 函数ID：0037[测试数据库中的表是否存在] ‘‘‘‘
‘‘‘‘ 函数ID：0038[在线HTML编辑器] ‘‘‘‘
‘‘‘‘ 函数ID：0039[判断是否奇数] ‘‘‘‘
‘‘‘‘ 函数ID：0040[生成验证码图像BMP] ‘‘‘‘
‘‘‘‘ 函数ID：0041[生成随机密码] ‘‘‘‘
‘‘‘‘ 函数ID：0042[字符加解密] ‘‘‘‘
‘‘‘‘ 函数ID：0043[解密字符加解密] ‘‘‘‘
‘‘‘‘ 函数ID：0044[创建数据表] ‘‘‘‘
‘‘‘‘ 函数ID：0045[在数据库中插入字段值] ‘‘‘‘
‘‘‘‘ 函数ID：0046[Cookie防乱码写入时用] ‘‘‘‘
‘‘‘‘ 函数ID：0047[Cookie防乱码读出时用] ‘‘‘‘
‘‘‘‘ 函数ID：0048[检测用户名和密码是否正确] ‘‘‘‘
‘‘‘‘ 函数ID：0049[生成时间的整数] ‘‘‘‘
‘‘‘‘ 函数ID：0050[获得栏目的所有子栏目字符串并用","隔开]
‘‘‘‘ ‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘**************************************************‘‘‘‘
‘函数ID：0001[截字符串]
‘函数名：SubstZFC
‘作用：截字符串，汉字一个算两个字符，英文算一个字符
‘参数：str ----原字符串
‘ strlen ----截取长度
‘返回值：截取后的字符串
‘**************************************************
Public Function SubstZFC(ByVal str, ByVal strlen)
If str = "" Then
SubstZFC = ""
Exit Function
End If
Dim l, t, c, i, strTemp
str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = Len(str)
t = 0
strTemp = str
strlen = CLng(strlen)
For i = 1 To l
c = Abs(Asc(Mid(str, i, 1)))
If c > 255 Then
t = t + 2
Else
t = t + 1
End If
If t >= strlen Then
strTemp = Left(str, i)
Exit For
End If
Next
SubstZFC = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<")
End Function
‘**************************************************
‘函数ID：0002[过滤html]
‘函数名：GlHtml
‘作用：过滤html 元素
‘参数：str ---- 要过滤字符
‘返回值：没有html 的字符
‘**************************************************
Public Function GlHtml(ByVal str)
If IsNull(str) Or Trim(str) = "" Then
GlHtml = ""
Exit Function
End If
Dim re
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "(\<.[^\<]*\>)"
str = re.Replace(str, " ")
re.Pattern = "(\<\/[^\<]*\>)"
str = re.Replace(str, " ")
Set re = Nothing
str = Replace(str, "‘", "")
str = Replace(str, Chr(34), "")
GlHtml = str
End Function
‘**************************************************
‘函数ID：0003[打开任意数据表并显示表结构及内容]
‘函数名：OpOtherDB
‘作用：打开任意数据表并显示表结构及内容
‘参数：DBtheStr ---- 要打开表的数据库链接字串
‘参数：Opentdname ---- 要打开表名
‘返回值：显示表结构及内容
‘**************************************************
Public Function OpOtherDB(ByVal DBtheStr,ByVal Opentdname)
Response.write "" & vbCrlf
Set Opdb_Conn=server.createobject("ADODB.Connection")
Set Opdb_Rs =server.createobject("ADODB.Recordset")
Opdb_Conn.open DBtheStr
Opdb_sql_str="select * from "&Opentdname
Opdb_Rs.open Opdb_Sql_Str,Opdb_Conn,1,1
Nfieldnumber=Opdb_Rs.Fields.count
If Nfieldnumber >0 then
Response.write "" & vbCrlf
For i=0 to (Nfieldnumber-1)
Response.write "" & vbCrlf
Next
temptbi=0
Do While Not Opdb_Rs.Eof
Response.write "" & vbCrlf
For i=0 to (Nfieldnumber-1)
If (temptbi<2) Then
Response.write "" & vbCrlf
temptbi=temptbi+1
Else
Response.write "" & vbCrlf
If temptbi>=3 Then
temptbi=0
Else
temptbi=temptbi+1
End If
End If
Next
Opdb_Rs.MoveNext
Response.write "" & vbCrlf
Loop
End If
Opdb_Rs.Close
Opdb_Conn.Close
Set Opdb_Rs = Nothing
Set Opdb_Conn=Nothing
Response.write "

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

" & vbCrlf
End function
‘**************************************************
‘函数ID：0004[读取两种路径]
‘函数名：Readsyspath
‘作用：读取路径
‘参数：lx ---- 0:服务器IP加路径 1:服务物理路径
‘返回值：路径字串
‘**************************************************
Public Function Readsyspath(ByVal lx)
Dim templj,aryTemp,newpath
templj=""
newpath=""
If lx=0 Then
templj="http://"&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("(\<.[^\<]*\>)","
")
‘**************************************************
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")
‘使用表单提取文件
‘**************************************************
Public Function UpFsRn(ByVal RetSize,ByVal Fdir,ByVal Objwj)
UpFsRn=False
Dim oUpStream,oStream,formsize,Formdata,strFileName,strFileDir,ObjAllPath,datastart,dataend
strFileDir = Fdir
strFileName = Swj
ObjAllPath = ""
If Right(strFileDir,1)<>"\" Then strFileDir=strFileDir&"\"
ObjAllPath =strFileDir&Objwj
If CheckFile(ObjAllPath) Then DelFile(ObjAllPath)
formsize=Request.TotalBytes
if (formsize<=(RetSize*1024*1024)) then
Formdata=Request.BinaryRead(formsize)
Pos_ts=LenB(getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))
Pos_b=InstrB(Formdata,getByteString(Chr(13) & Chr(10) & Chr(13) & Chr(10)))+Pos_ts
nFormdata=MidB(Formdata,Pos_b)
Pos_ts=InstrB(nFormdata,getByteString(Chr(13) & Chr(10) & "--"))
nnFormdata=MidB(nFormdata,Pos_ts)
Pos_e=LenB(Formdata)-LenB(nnFormdata)-Pos_b+1
datastart =Pos_b
dataend=Pos_e
set oUpStream = Server.CreateObject("adodb.stream")
oUpStream.Type = 1
oUpStream.Mode = 3
oUpStream.Open
set oStream = Server.CreateObject("adodb.stream")
oStream.Type = 1
oStream.Mode = 3
oStream.Open
oUpStream.Write Formdata
oUpStream.position=datastart-1
oUpStream.copyto oStream,dataend
oStream.SaveToFile ObjAllPath,2
oStream.Close
set oStream=nothing
UpFsRn=True
End If
End function
‘**************************************************
‘函数ID：0019[过滤HTML脚本]
‘函数名：FilterJS
‘作用：过滤HTML脚本
‘参数：strHTML ---- 被检测的HTML字串
‘返回值：返回过滤后的HTML
‘**************************************************
Function FilterJS(ByVal strHTML)
Dim objReg,strContent
If IsNull(strHTML) OR strHTML="" Then Exit Function
Set objReg=New RegExp
objReg.IgnoreCase =True
objReg.Global=True
objReg.Pattern="(&#)"
strContent=objReg.Replace(strHTML,"")
objReg.Pattern="(function|meta|value|window\.|script|js:|about:|file:|Document\.|vbs:|frame|cookie)"
strContent=objReg.Replace(strContent,"")
objReg.Pattern="(on(finish|mouse|Exit=|error|click|key|load|focus|Blur))"
strContent=objReg.Replace(strContent,"")
FilterJS=strContent
strContent=""
Set objReg=Nothing
End Function
‘**************************************************
‘函数ID：0020[创建MsAccess数据库]
‘函数名：CrDb_MsAccess
‘作用：创建MsAccess数据库
‘参数：DbPath ---- 目标目录信息
‘参数：DbFileName ---- 目标库文件名称
‘参数：DbUpwd ---- 目标库打开密码
‘返回值：建立成功返回 True 否则 False
‘**************************************************
Public Function CrDb_MsAccess(ByVal DbPath,ByVal DbFileName,ByVal DbUpwd)
CrDb_MsAccess=False
On Error GoTo 0
On Error Resume Next
DIM fxztxt,fu_fu_db_str,fu_db_str
fxztxt=Chr(60)&"%Response.end()%"&Chr(62)
If Right(DbPath,1)<>"\" Then DbPath=DbPath & "\"
fu_fu_db_str="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&"temp.mdb;"
fu_db_str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&DbPath&DbFileName&";Jet OLEDB:Database Password="&DbUpwd&";"
Set fu_Ca = Server.CreateObject("ADOX.Catalog")
fu_Ca.Create fu_fu_db_str
Set fu_Ca = Nothing
Set fu_Je = Server.CreateObject("JRO.JetEngine")
fu_Je.CompactDatabase fu_fu_db_str,fu_db_str
Set fu_fso = CreateObject("Scripting.FileSystemObject")
fu_fso.DeleteFile(DbPath&"temp.mdb")
Set fu_Je = Nothing
Set fu_fso = Nothing
set fu_Conn =server.createobject("ADODB.Connection")
set fu_Rs =server.createobject("ADODB.Recordset")
fu_Conn.open fu_db_str
fu_Sql_Str="CREATE TABLE [0] ([0] Text DEFAULT Notxt NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"
fu_Conn.Execute(fu_Sql_Str)
fu_Sql_Str="Select * From [0]"
fu_Rs.open fu_Sql_Str,fu_Conn,1,3
fu_Rs.addnew
fu_Rs("0")=fxztxt
fu_Rs.update
fu_Rs.Close
fu_Conn.Close
Set fu_Rs = Nothing
Set fu_Conn = Nothing
If Err.Number = 0 Then
CrDb_MsAccess=True
End If
On Error GoTo 0
End function
‘**************************************************
‘函数ID：0021[创建MsSQLServer数据库]
‘函数名：CrDb_MsSQLServer
‘作用：创建MsSQLServer数据库
‘参数：DbIp ---- 数据库所在IP或主机名称
‘参数：DbSamc ---- 数据库超管用户名称
‘参数：DbSapwd---- 数据库超管用户口令
‘参数：DbName ---- 新建数据库名称
‘参数：DbUpmc ---- 新建数据库所属用户名称
‘参数：DbUpwd ---- 新建数据库所属用户密码
‘返回值：建立成功返回 True 否则 False
‘**************************************************
Public Function CrDb_MsSQLServer(ByVal DbIp,ByVal DbSamc,ByVal DbSapwd,ByVal DbName,ByVal DbUpmc,ByVal DbUpwd)
CrDb_MsSQLServer=False
On Error GoTo 0
On Error Resume Next
DIM fu_Sa_Str,fu_Ua_Str,fu_Conn,fu_Rs,fu_Sql_Str,fxztxt
fxztxt=Chr(60)&"%Response.end()%"&Chr(62)
fu_Sa_Str ="DRIVER=SQL Server;UID="&DbSamc&";DATABASE=master;SERVER="&DbIp&";PWD="&DbSapwd&";"
fu_Ua_Str ="DRIVER=SQL Server;UID="&DbUpmc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbUpwd&";"
Set fu_Conn = Server.CreateObject("ADODB.Connection")
fu_Conn.Open fu_Sa_Str
fu_Conn.Execute "CREATE DATABASE " &DbName
fu_Conn.Close
fu_DB_Conn_Str="DRIVER=SQL Server;UID="&DbSamc&";DATABASE="&DbName&";SERVER="&DbIp&";PWD="&DbSapwd&";"
fu_Conn.Open fu_DB_Conn_Str
fu_Sql_Str="EXEC sp_addlogin ‘"&DbUpmc&"‘,‘"&DbUpwd&"‘,‘"&DbName&"‘"
fu_Conn.Execute fu_Sql_Str
fu_Sql_Str="EXEC sp_grantdbaccess ‘"&DbUpmc&"‘"
fu_Conn.Execute fu_Sql_Str
fu_Sql_Str="EXEC sp_addrolemember ‘db_owner‘, ‘"&DbUpmc&"‘"
fu_Conn.Execute fu_Sql_Str
fu_Sql_Str="EXEC sp_defaultdb "&DbUpmc&","&DbName
fu_Conn.Execute fu_Sql_Str
fu_Conn.Close
fu_Conn.open fu_Ua_Str
fu_Sql_Str="CREATE TABLE [0] ([0] Text DEFAULT (‘Notxt‘) NOT NULL,[11] int IDENTITY (1, 1) NOT NULL PRIMARY KEY)"
fu_Conn.Execute fu_Sql_Str
Set fu_Rs=server.createobject("ADODB.Recordset")
fu_Sql_Str="Select * From [0]"
fu_Rs.open fu_Sql_Str,fu_Conn,1,3
fu_Rs.addnew
fu_Rs("0")=fxztxt
fu_Rs.update
fu_Rs.Close
fu_Conn.Close
Set fu_Rs = Nothing
Set fu_Conn=Nothing
If Err.Number = 0 Then
CrDb_MsSQLServer=True
End If
On Error GoTo 0
End function
‘**************************************************
‘函数ID：0022[通过JMAIL发信]
‘函数名：MSMail
‘作用：通过JMAIL发信
‘参数：subject ---- 邮件的标题
‘参数：mailaddress ---- 邮件服务器地址
‘参数：senderName ---- 发件人名称
‘参数：email ---- 收件人E-MAIL地址
‘参数：content ---- 邮件内容
‘参数：fromer ---- 发件人E-MAIL地址
‘参数：serEmailUser ---- 邮件服务器权限用户名
‘参数：serEmailPass ---- 邮件服务器权限用户密码
‘返回值：发送成功返回 True 否则 False
‘示例：MSMail("test","smtp.163.com","mzy","mzymcm@yahoo.com.cn","test","mzymcm@163.com","mzymcm","abcmzy1029abc")
‘**************************************************
Public Function MSMail(ByVal subject, ByVal mailaddress, ByVal senderName, ByVal email, ByVal content, ByVal fromer, ByVal serEmailUser, ByVal serEmailPass)
dim JmailMsg
MSMail=False
set JmailMsg=server.createobject("jmail.message")
JmailMsg.mailserverusername=serEmailUser
JmailMsg.mailserverpassword=serEmailPass
JmailMsg.addrecipient email
JmailMsg.from=fromer
JmailMsg.fromname=senderName
JmailMsg.charset="gb2312"
JmailMsg.logging=true
JmailMsg.silent=true
JmailMsg.subject=Subject
JmailMsg.body=Server.HTMLEncode(content)
JmailMsg.htmlbody=content
if not JmailMsg.send(mailaddress) then
MSMail=False
else
MSMail=True
end if
JmailMsg.close
set JmailMsg=nothing
End function
‘**************************************************
‘函数ID：0023[测试组件是否安装]
‘函数名：IsObjInstalled
‘作用：测试组件是否安装
‘参数：strClassString ---- 组件名称或标识字串
‘返回值：测试成功返回 True 否则 False
‘示例：IsObjInstalled("JMAIL.Message")
‘**************************************************
Public Function IsObjInstalled(ByVal strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
‘**************************************************
‘函数名：GetObjVer
‘作用：返回组件版本信息
‘参数：strClassString ---- 组件名称或标识字串
‘返回值：返回组件版本信息字串
‘示例：GetObjVer("JMAIL.Message")
‘**************************************************
Public Function GetObjVer(ByVal strClassString)
On Error Resume Next
GetObjVer=""
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then GetObjVer=xtestobj.version
Set xTestObj = Nothing
Err = 0
End Function
‘**************************************************
‘函数名：ListObjInfo
‘作用：列出组件安装信息
‘参数： ----
‘返回值：列出组件安装信息
‘示例：ListObjInfo()
‘**************************************************
Public Function ListObjInfo()
Dim TempBs,TempBsXX,TempObjType,tmpObjs
TempBs="×"
TempBsXX=""
TempObjType=""
tmpObjs=""
tmpObjs=tmpObjs& "JMail.Message|"
tmpObjs=tmpObjs& "ADODB.Stream|"
tmpObjs=tmpObjs& "MSWC.AdRotator|"
tmpObjs=tmpObjs& "MSWC.BrowserType|"
tmpObjs=tmpObjs& "MSWC.NextLink|"
tmpObjs=tmpObjs& "MSWC.Tools|"
tmpObjs=tmpObjs& "MSWC.Status|"
tmpObjs=tmpObjs& "MSWC.Counters|"
tmpObjs=tmpObjs& "MSWC.PermissionChecker|"
tmpObjs=tmpObjs& "Scripting.FileSystemObject|"
tmpObjs=tmpObjs& "adodb.connection|"
tmpObjs=tmpObjs& "SoftArtisans.FileUp|"
tmpObjs=tmpObjs& "SoftArtisans.FileManager|"
tmpObjs=tmpObjs& "CDONTS.NewMail|"
tmpObjs=tmpObjs& "Persits.MailSender|"
tmpObjs=tmpObjs& "LyfUpload.UploadFile|"
tmpObjs=tmpObjs& "Persits.Upload.1|"
tmpObjs=tmpObjs& "w3.upload|"
tmpObjs=Split(tmpObjs,"|")
Response.write "" & 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=""&tmpObjs(i)&""
TempBs="×"
TempBsXX=" "
End If
Response.write "" & vbCrlf
Response.write "" & vbCrlf
Response.write "" & vbCrlf
Response.write "" & vbCrlf
Response.write "" & vbCrlf
End If
Next
Response.write "

组件标识	√\|×	版本
"&TempObjType&"	"&TempBs&"	"&TempBsXX&"

" & 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 & "" & vbCrlf
PosImageWin=PosImageWin & ""&vbCrlf
PosImageWin=PosImageWin & "" & vbCrlf
PosImageWin=PosImageWin & "" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & "选择文件：" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & "文件ID号：
" & vbCrlf
PosImageWin=PosImageWin & "文件名称：
" & vbCrlf
PosImageWin=PosImageWin & "文件类型：
" & vbCrlf
PosImageWin=PosImageWin & "文件介绍：" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & " " & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
Response.Write "" & vbCrlf
Response.Write "" & 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 "

"
‘**************************************************
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
%>
原始函数文链接下载地址为:www.lovemycn.com/index.asp?job=vn&id=200606132019599558
[这消息被mzymcm编辑过(最后编辑时间2006-06-13 20:40:42)]
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：2

发表于 2006-05-13 11:53:08 资料邮件悄悄话搜索引用举报不良信息
原始函数文链接下载地址为:als.lovemycn.com/functions/Aspfunction.ini
yjmyzz

终级用户
积分：583
发贴：174
来自：上海
注册：2004-03-03

返回页首 | 楼层：3

发表于 2006-05-13 13:29:50 资料邮件悄悄话搜索引用举报不良信息
好象没我的多哦,偶的有43个函数,因为决定慢慢转到asp.net了,所以这些函数可能也没多少机会用到了,公布出来,希望对大家有用,大家可以随意使用,欢迎交流QQ:278919507
www.1jq.net/myblog/article.asp?id=7
哎,现在公司头头居然要把asp/asp.net换到php,搞不懂,又没地方去了
做了4年ASP开发，还是转ASP.NET了，哎,MS就是强... (QQ:278919507 Mobile:13524030349 MSN:yjmyzy@hotmail.com)
hmly

终级用户
积分：1006
发贴：309
来自：人猿洞
注册：2005-08-03

返回页首 | 楼层：4

发表于 2006-05-13 13:47:29 资料邮件主页悄悄话搜索引用举报不良信息
不管怎么说.感谢两位的无私!!
玄幻书殿:http://www.xhsd.net
ytar

超级用户
积分：301
发贴：81
来自：
注册：2005-04-21

返回页首 | 楼层：5

发表于 2006-05-13 13:56:16 资料邮件悄悄话搜索引用举报不良信息
我也来贴些,上面的对我有用,呵呵,不能白拿
Asp中一些FSO方面的函数
‘//==================================文件操作==================================
‘取文件大小
Function GetFileSize(FileName)
‘//功能：取文件大小
‘//形参：文件名
‘//返回值：成功为文件大小，失败为-1
‘//
Dim f
If ReportFileStatus(FileName) = 1 Then
Set f = fso.Getfile(FileName)
GetFileSize = f.Size
Else
GetFileSize = -1
End if
End Function
‘文件删除
Function deleteAFile(filespec)
‘//功能：文件删除
‘//形参：文件名
‘//返回值：成功为1，失败为-1
‘//
If ReportFileStatus(filespec) = 1 Then
fso.deleteFile(filespec)
deleteAFile = 1
Else
deleteAFile = -1
End if
End Function
‘显示文件列表
Function ShowFileList(folderspec)
‘//功能：目录存在时显示此目录下的所有文件
‘//形参：目录名
‘//返回值：成功为文件列表，失败为-1
‘//
Dim f, f1, fc, s
If ReportFolderStatus(folderspec) = 1 Then
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
s = s & f1.name
s = s & "|"
Next
ShowFileList = s
Else
ShowFileList = -1
End if
End Function
‘!!!
‘文件复制
Function CopyAFile(SourceFile,DestinationFile)
‘//功能：源文件存在时，才能对文件进行复制，目的文件无影响
‘//形参：源文件，目的文件
‘//返回值：成功为1，失败为-1
‘//
Dim MyFile
If ReportFileStatus(SourceFile) = 1 Then
Set MyFile = fso.GetFile(SourceFile)
MyFile.Copy (DestinationFile)
CopyAFile = 1
Else
CopyAFile = -1
End if
End Function
‘文件移动
‘Response.Write MoveAFile("f:\123\4561.exe","f:\123\4562.txt")
Function MoveAFile(SourceFile,DestinationFile)
‘//功能：源文件存在时目的文件不存在时才能对文件进行移动
‘//形参：源文件，目的文件
‘//返回值：成功为1，失败为-1
‘//
If ReportFileStatus(SourceFile)=1 And
ReportFileStatus(DestinationFileORPath) =
-1 Then
fso.MoveFile SourceFile,DestinationFileORPath
MoveAFile = 1
Else
MoveAFile = -1
End if
End Function
‘文件是否存在？
‘Response.Write ReportFileStatus("G:\soft\delphi\my_pro\代码库.exe")
Function ReportFileStatus(FileName)
‘//功能：判断文件是否存在
‘//形参：文件名
‘//返回值：成功为1，失败为-1
‘//
Dim msg
msg = -1
If (fso.FileExists(FileName)) Then
msg = 1
Else
msg = -1
End If
ReportFileStatus = msg
End Function
‘文件创建日期
‘Response.Write ShowDatecreated("G:\soft\delphi\my_pro\代码库.exe")
‘Response.Write ShowDatecreated("G:\soft\delphi\my_pro\复件
代码库.exe")
Function ShowDatecreated(filespec)
‘//功能：文件创建日期
‘//形参：文件名
‘//返回值：成功：文件创建日期，失败：-1
‘//
Dim f
If ReportFileStatus(filespec) = 1 Then
Set f = fso.GetFile(filespec)
ShowDatecreated = f.Datecreated
Else
ShowDatecreated = -1
End if
End Function
‘文件属性
‘Response.Write GetAttributes("G:\soft\delphi\my_pro\复件
代码库.exe")
Function GetAttributes(FileName)
‘//功能：显示文件属性
‘//形参：文件名
‘//返回值：成功：文件属性，失败：-1
‘//
Dim f,Str
If ReportFileStatus(FileName) = 1 Then
Set f = fso.GetFile(FileName)
select Case f.attributes
Case 0 Str="普通文件。没有设置任何属性。 "
Case 1 Str="只读文件。可读写。 "
Case 2 Str="隐藏文件。可读写。 "
Case 4 Str="系统文件。可读写。 "
Case 16 Str="文件夹或目录。只读。 "
Case 32 Str="上次备份后已更改的文件。可读写。 "
Case 1024 Str="链接或快捷方式。只读。 "
Case 2048 Str=" 压缩文件。只读。"
End select
GetAttributes = Str
Else
GetAttributes = -1
End if
End Function
‘最后一次访问/最后一次修改时间
‘Response.Write ShowFileAccessInfo("G:\soft\delphi\my_pro\复件
代码库.exe")
Function ShowFileAccessInfo(FileName,InfoType)
‘//功能：显示文件创建时信息
‘//形参：文件名,信息类别
‘// 1 -----创建时间
‘// 2 -----上次访问时间
‘// 3 -----上次修改时间
‘// 4 -----文件路径
‘// 5 -----文件名称
‘// 6 -----文件类型
‘// 7 -----文件大小
‘// 8 -----父目录
‘// 9 -----根目录
‘//返回值：成功为文件创建时信息，失败：-1
‘//
Dim f, s
If ReportFileStatus(FileName) = 1 then
Set f = fso.GetFile(FileName)
select Case InfoType
Case 1 s = f.Datecreated ‘// 1 -----
创建时间
Case 2 s = f.DateLastAccessed ‘// 2 -----上次访问
时间
Case 3 s = f.DateLastModified ‘// 3 -----上次修改
时间
Case 4 s = f.Path ‘// 4
-----文件路径
Case 5 s = f.Name ‘// 5
-----文件名称
Case 6 s = f.Type ‘// 6
-----文件类型
Case 7 s = f.Size ‘// 7
-----文件大小
Case 8 s = f.ParentFolder ‘// 8 -----
父目录
Case 9 s = f.RootFolder ‘// 8 -----
根目录
End select
ShowFileAccessInfo = s
ELse
ShowFileAccessInfo = -1
End if
End Function
‘写文本文件
Function WriteTxtFile(FileName,TextStr,WriteORAppendType)
Const ForReading = 1, ForWriting = 2 , ForAppending = 8
Dim f, m
select Case WriteORAppendType
Case 1: ‘文件进行写操作
Set f = fso.OpenTextFile(FileName, ForWriting, True)
f.Write TextStr
f.Close
If ReportFileStatus(FileName) = 1 then
WriteTxtFile = 1
Else
WriteTxtFile = -1
End if
Case 2: ‘文件末尾进行写操作
If ReportFileStatus(FileName) = 1 then
Set f = fso.OpenTextFile(FileName, ForAppending)
f.Write TextStr
f.Close
WriteTxtFile = 1
Else
WriteTxtFile = -1
End if
End select
End Function
‘读文本文件
Function ReadTxtFile(FileName)
Const ForReading = 1, ForWriting = 2
Dim f, m
If ReportFileStatus(FileName) = 1 then
Set f = fso.OpenTextFile(FileName, ForReading)
m = f.ReadLine
‘m = f.ReadAll
‘f.SkipLine
ReadTxtFile = m
f.Close
Else
ReadTxtFile = -1
End if
End Function
‘建立文本文件
‘//==================================目录操作==================================
‘取目录大小
Function GetFolderSize(FolderName)
‘//功能：取目录大小
‘//形参：目录名
‘//返回值：成功为目录大小，失败为-1
‘//
Dim f
If ReportFolderStatus(FolderName) = 1 Then
Set f = fso.GetFolder(FolderName)
GetFolderSize = f.Size
Else
GetFolderSize = -1
End if
End Function
‘创建的文件夹
Function createFolderDemo(FolderName)
‘//功能：创建的文件夹
‘//形参：目录名
‘//返回值：成功为1，失败为-1
‘//
Dim f
If ReportFolderStatus(Folderspec) = 1 Then
createFolderDemo = -1
Else
Set f = fso.createFolder(FolderName)
createFolderDemo = 1
End if
End Function
‘!!!
‘目录删除
Function deleteAFolder(Folderspec)
‘//功能：目录删除
‘//形参：目录名
‘//返回值：成功为1，失败为-1
‘//
Response.write Folderspec
If ReportFolderStatus(Folderspec) = 1 Then
fso.deleteFolder (Folderspec)
deleteAFolder = 1
Else
deleteAFolder = -1
End if
End Function
‘显示目录列表
Function ShowFolderList(folderspec)
‘//功能：目录存在时显示此目录下的所有子目录
‘//形参：目录名
‘//返回值：成功为子目录列表，失败为-1
‘//
Dim f, f1, fc, s
If ReportFolderStatus(folderspec) = 1 Then
Set f = fso.GetFolder(folderspec)
Set fc = f.SubFolders
For Each f1 in fc
s = s & f1.name
s = s & "|"
Next
ShowFolderList = s
Else
ShowFolderList = -1
End if
End Function
‘!!!!
‘目录复制
Function CopyAFolder(SourceFolder,DestinationFolder)
‘//功能：源目录存在时，才能对目录进行复制，目的目录无影响
‘//形参：源目录，目的目录
‘//返回值：成功为1，失败为-1
‘//
‘Dim MyFolder
‘If ReportFolderStatus(SourceFolder) = 1 and ReportFolderStatus
(DestinationFolder) = -1 Then
‘Set MyFolder = fso.GetFolder(SourceFolder)
fso.CopyFolder SourceFolder,DestinationFolder
CopyAFolder = 1
‘Else
CopyAFolder = -1
‘End if
End Function
‘目录进行移动
Function MoveAFolder(SourcePath,DestinationPath)
‘//功能：源目录存在时目的目录不存在时才能对目录进行移动
‘//形参：源目录，目的目录
‘//返回值：成功为1，失败为-1
‘//
If ReportFolderStatus(SourcePath)=1 And
ReportFolderStatus(DestinationPath)=0
Then
fso.MoveFolder SourcePath, DestinationPath
MoveAFolder = 1
Else
MoveAFolder = -1
End if
End Function
‘判断目录是否存在
‘Response.Write ReportFolderStatus("G:\soft\delphi\my_pro\")
Function ReportFolderStatus(fldr)
‘//功能：判断目录是否存在
‘//形参：目录
‘//返回值：成功为1，失败为-1
‘//
Dim msg
msg = -1
If (fso.FolderExists(fldr)) Then
msg = 1
Else
msg = -1
End If
ReportFolderStatus = msg
End Function
‘目录创建时信息
Function ShowFolderAccessInfo(FolderName,InfoType)
‘//功能：显示目录创建时信息
‘//形参：目录名,信息类别
‘// 1 -----创建时间
‘// 2 -----上次访问时间
‘// 3 -----上次修改时间
‘// 4 -----目录路径
‘// 5 -----目录名称
‘// 6 -----目录类型
‘// 7 -----目录大小
‘// 8 -----父目录
‘// 9 -----根目录
‘//返回值：成功为目录创建时信息，失败：-1
‘//
Dim f, s
If ReportFolderStatus(FolderName) = 1 then
Set f = fso.GetFolder(FolderName)
select Case InfoType
Case 1 s = f.Datecreated ‘// 1 -----
创建时间
Case 2 s = f.DateLastAccessed ‘// 2 -----上次访问
时间
Case 3 s = f.DateLastModified ‘// 3 -----上次修改
时间
Case 4 s = f.Path ‘// 4
-----文件路径
Case 5 s = f.Name ‘// 5
-----文件名称
Case 6 s = f.Type ‘// 6
-----文件类型
Case 7 s = f.Size ‘// 7
-----文件大小
Case 8 s = f.ParentFolder ‘// 8 -----
父目录
Case 9 s = f.RootFolder ‘// 9 -----
根目录
End select
ShowFolderAccessInfo = s
ELse
ShowFolderAccessInfo = -1
End if
End Function
Function DisplayLevelDepth(pathspec)
Dim f, n ,Path
Set f = fso.GetFolder(pathspec)
If f.IsRootFolder Then
DisplayLevelDepth ="指定的文件夹是根文件夹。"&RootFolder
Else
Do Until f.IsRootFolder
Path = Path & f.Name &"
"
Set f = f.ParentFolder
n = n + 1
Loop
DisplayLevelDepth ="指定的文件夹是嵌套级为 " & n & "
的文件夹。
"&
Path
End If
End Function
‘//==================================磁盘操作==================================
‘驱动器是否存在？
‘Response.Write ReportDriveStatus("C:\")
Function ReportDriveStatus(drv)
‘//功能：判断磁盘是否存在
‘//形参：磁盘
‘//返回值：成功为1，失败为-1
‘//
Dim msg
msg = -1
If fso.DriveExists(drv) Then
msg = 1
Else
msg = -1
End If
ReportDriveStatus = msg
End Function
‘--------可用的返回类型包括 FAT、NTFS 和 CDFS。
‘Response.Write ShowFileSystemType("C:\")
Function ShowFileSystemType(drvspec)
‘//功能：磁盘类型
‘//形参：磁盘名
‘//返回值：成功为类型：FAT、NTFS 和 CDFS，失败：-1
‘//
Dim d
If ReportDriveStatus(drvspec) = 1 Then
Set d = fso. GetDrive(drvspec)
ShowFileSystemType = d.FileSystem
ELse
ShowFileSystemType = -1
End if
End Function
End Class
%>
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：6

发表于 2006-05-14 11:10:16 资料邮件悄悄话搜索引用举报不良信息
‘**************************************************‘‘‘‘
‘函数ID：0022[取得图像的类型|宽|高]
‘函数名：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)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
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：8

发表于 2006-05-15 07:08:48 资料邮件悄悄话搜索引用举报不良信息
希望在这能使回复变成ASP实用函数集散地!!
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：9

发表于 2006-05-15 07:11:14 资料邮件悄悄话搜索引用举报不良信息
‘‘‘‘===============================================‘‘‘‘
‘‘‘‘ 函数制作说明 ‘‘‘‘
‘‘‘‘ 本函数库作者：马政永，内蒙古阿拉善 ‘‘‘‘
‘‘‘‘作者主页：www.lovemycn.com or als.lovemycn.com ‘‘‘‘
‘‘‘‘作者邮箱：mzymcm@yahoo.com.cn Phone:13947490036‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ 本函数免费提供使用，但不要去版权信息 ‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ 本函数库还在丰富中，多谢支持 ‘‘‘‘
‘‘‘‘-----------------------------------------------‘‘‘‘
‘**************************************************‘‘‘‘
‘函数ID：0030[将本地数据表或库上传并导入到服务器数据库的表中]
‘函数名：ReadCdbToServ
‘作用：将本地数据表或库上传并导入到服务器数据库的表中
‘参数：CdbFileUp ---- 被上传的库或表文件路径及文件名
‘参数：SdbConnStr ---- 服务器数据库链接字串
‘参数：SdbTbname ---- 服务器将打开的表名
‘参数：FildStrArr ---- 导入的数据字段串(各字段用","隔开)
‘返回值：成功返回 True 否则 False
‘注可导入的文件类型有(0:Excel 1:Access 2:Text 3

BF/FoxPro)
‘注：Excel 的表为Sheet名称，文本及DBF/FoxPro的表名为数据文件的全名，如 aa.txt 或 aa.dbf
‘注：Text 文本数据表是以","为分隔的格式，重点：被导入的数据库只能包含一个表，并且导入的字段应和服务器数据库的表相一致
‘示例： TempSj=Request.Form("Tfile"

‘示例： If Trim(TempSj)<>"" Then CALL ReadCdbToServ(TempSj,"DRIVER=SQL Server;UID=sa;DATABASE=temp;SERVER=127.0.0.1;PWD=mzy1029;","img","mc,lx,mem"

‘示例： Response.write ""
‘**************************************************‘‘‘‘
Public Function ReadCdbToServ(ByVal CdbFileUp,ByVal SdbConnStr,ByVal SdbTbname,ByVal FildStrArr)
ReadCdbToServ=False
Dim MbDir,Mbwjmc,aryTemp,VrCdb_Conn_Str,oTemp_Conn,oTemp_Rs,sTemp_Conn,sTemp_Rs,oTemp_sql_str,sTemp_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(CdbFileUp,MbDir,Mbwjmc) Then
If Gtlx="XLS" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="&MbDir&Mbwjmc&";" ‘‘ Excel [Tbname$]
If Gtlx="MDB" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&Mbwjmc&";Jet OLEDB

atabase 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 sTemp_Conn=server.createobject("ADODB.Connection"

Set sTemp_Rs =server.createobject("ADODB.Recordset"

sTemp_Conn.open SdbConnStr
sTemp_sql_str="select "&FildStrArr&" from "&SdbTbname
Set oTemp_Conn=server.createobject("ADODB.Connection"

Set oTemp_Rs =server.createobject("ADODB.Recordset"

oTemp_Conn.open VrCdb_Conn_Str
Set TpTrs=oTemp_Conn.OpenSchema(20)
CdbTbname=TpTrs(2)
TpTrs.Close
Set TpTrs = Nothing
If Gtlx="XLS" Then CdbTbname="["&CdbTbname&"]"
oTemp_sql_str="select "&FildStrArr&" from "&CdbTbname
oaryTemp = Split(FildStrArr,","

sTemp_Rs.open sTemp_sql_str,sTemp_Conn,1,3
oTemp_Rs.open oTemp_sql_str,oTemp_Conn,1,3
Do While Not oTemp_Rs.Eof
sTemp_Rs.addnew
For i = LBound(oaryTemp) To UBound(oaryTemp)
sTemp_Rs(oaryTemp(i))=oTemp_Rs(oaryTemp(i))
Next
sTemp_Rs.update
oTemp_Rs.MoveNext
Loop
oTemp_Rs.Close
oTemp_Conn.Close
Set oTemp_Rs = Nothing
Set oTemp_Conn=Nothing
sTemp_Rs.Close
sTemp_Conn.Close
Set sTemp_Rs = Nothing
Set sTemp_Conn=Nothing
ReadCdbToServ=True
DelFile(MbDir&Mbwjmc)
End If
End Function
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：10

发表于 2006-05-15 07:12:07 资料邮件悄悄话搜索引用举报不良信息
‘**************************************************‘‘‘‘
‘函数ID：0029[将本地文件进行二进制分析，并保存到服务器的指定目录下]
‘函数名：TxtBinInfo
‘作用：将本地文件进行二进制分析，并保存到服务器的指定目录下
‘参数：Filestr ---- 被分析文件路径及文件命名
‘参数：WebSvFile ---- 分析信息保存文件路径及文件命名
‘返回值：成功返回 True 否则 False
‘示例： TempSj=Request.Form("Tfile"

‘示例： If Trim(TempSj)<>"" Then CALL TxtBinInfo(TempSj,"d:\aa.txt"

‘示例： Response.write ""
‘**************************************************‘‘‘‘
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
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：11

发表于 2006-05-15 07:13:30 资料邮件悄悄话搜索引用举报不良信息
‘**************************************************
‘函数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)
bncrlf=chrB(13)&chrB(10)
divider=leftB(formdata,CLng(JCID(instrb(formdata,bncrlf)))-1)
datastart=instrb(formdata,bncrlf&bncrlf)+4
dataend=instrb(datastart+1,formdata,divider)-datastart
mydata=midb(formdata,datastart,dataend)
End If
GetImageData=mydata
End Function
mzymcm

初级用户
积分：75
发贴：22
来自：
注册：2005-03-02

返回页首 | 楼层：12

发表于 2006-05-15 07:14:37 资料邮件悄悄话搜索引用举报不良信息
‘‘‘‘===============================================‘‘‘‘
‘‘‘‘ 函数制作说明 ‘‘‘‘
‘‘‘‘ 本函数库作者：马政永，内蒙古阿拉善 ‘‘‘‘
‘‘‘‘作者主页：www.lovemycn.com or als.lovemycn.com ‘‘‘‘
‘‘‘‘作者邮箱：mzymcm@yahoo.com.cn Phone:13947490036‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ 本函数免费提供使用，但不要去版权信息 ‘‘‘‘
‘‘‘‘ ‘‘‘‘
‘‘‘‘ 本函数库还在丰富中，多谢支持 ‘‘‘‘
‘‘‘‘-----------------------------------------------‘‘‘‘
‘**************************************************
‘函数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
‘**************************************************
‘函数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 & "" & vbCrlf
PosImageWin=PosImageWin & ""&vbCrlf
PosImageWin=PosImageWin & "" & vbCrlf
PosImageWin=PosImageWin & "" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & "选择文件：" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & " " & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
PosImageWin=PosImageWin & "

" & vbCrlf
Response.Write "" & vbCrlf
Response.Write "" & vbCrlf
Response.Write "" & vbCrlf
End Function
_xyz

马政永作的标准ASP应用函数库马政永作的标准ASP应用函数库 - 经典论坛 ASP中XML的应用 ASP网页模板的应用 ASP实用函数库大全浏览代码脚本代码 IT人家 WEB编程开发常用的代码-ASP教程,ASP应用 ASP关于数组的应用技巧 ASP.NET应用中十大常见的潜在问题 ASP网页模板的应用 - 软件开发专题网站 WEB应用中报表打印的实现 - asp教程金融行业的 XML 标准及应用压缩解压缩的函数库zlib的使用--gqlyxg1981的博客压缩解压缩的函数库zlib的使用--gqlyxg1981的博客 ASP应用之模板采用 ASP注入应用漏洞解决方法 Asp.netMVC应用程结构网络函数库 Xlib 函数库 QTP函数库使用 Web 标准生成 ASP.NET 2.0 Web 站点 - jelink的专栏 - ... 利用 ASP.NET、JavaScript 和 OLE DB 从头设计您自己的网络日记应用... ASP.NET开发平台,应用框架 ASP.NET Web Page应用深入探讨 ASP.NET中随机数生成及应用