|
源代码网推荐
源代码网整理以下"**************************************************""""
"函数ID：0029[将本地文件进行二进制分析，并保存到服务器的指定目录下]
"函数名：TxtBinInfo
"作 用：将本地文件进行二进制分析，并保存到服务器的指定目录下
"参 数：Filestr ---- 被分析文件路径及文件命名
"参 数：WebSvFile ---- 分析信息保存文件路径及文件命名
"返回值：成功返回 True 否则 False
"示 例： TempSj=Request.Form("Tfile")
"示 例： If Trim(TempSj)<>"" Then CALL TxtBinInfo(TempSj,"d:aa.txt")
"示 例： Response.write "<form method="POST" action="test.asp"><input type="file" name="Tfile"><input type="submit" value="提交" name="B1"></form>"
"**************************************************""""
Public Function TxtBinInfo(ByVal Filestr,ByVal WebSvFile)
TxtBinInfo=False
DIM Wtempxx
Wtempxx=""
SET Tempsm = Server.CreateObject("ADODB.Stream")
Tempsm.Mode=3
Tempsm.Type=1
Tempsm.Open
Tempsm.LoadFromFile (Filestr)
tempRedImg=Tempsm.Read
for i = lenb(tempRedImg) to 1 step -1
Wtempxx=Wtempxx& "地址号：" &i &"地址十六进制："& Hex(ascb(midb(tempRedImg,i,1))) &" 十进制："&ascb(midb(tempRedImg,i,1))&vbCrlf
next
Wtempxx=Wtempxx&vbCrlf&"大小："&lenb(tempRedImg)&"字节 该文件名称为：" &Filestr
Set M_fso = CreateObject("Scripting.FileSystemObject")
Set FnameN= M_fso.OpenTextFile(WebSvFile,2,True)
FnameN.Write Wtempxx
FnameN.Close
Set M_fso = Nothing
Tempsm.Close
SET Tempsm=nothing
TxtBinInfo=True
End Function
"**************************************************""""
"函数ID：0030[将本地数据表或库上传并导入到服务器数据库的表中]
"函数名：ReadCdbToServ
"作 用：将本地数据表或库上传并导入到服务器数据库的表中
"参 数：CdbFileUp ---- 被上传的库或表文件路径及文件名
"参 数：SdbConnStr ---- 服务器数据库链接字串
"参 数：SdbTbname ---- 服务器将打开的表名
"参 数：FildStrArr ---- 导入的数据字段串(各字段用","隔开)
"返回值：成功返回 True 否则 False
"注可导入的文件类型有(0:Excel 1:Access 2:Text 3:DBF/FoxPro)
"注：Excel 的表为Sheet名称，文本及DBF/FoxPro的表名为数据文件的全名，如 aa.txt 或 aa.dbf
"注：Text 文本数据表是以","为分隔的格式 ，重点：被导入的数据库只能包含一个表，并且导入的字段应和服务器数据库的表相一致
"示 例： CALL ReadCdbToServ(TempSj,"DRIVER=SQL Server;UID=sa;DATABASE=temp;SERVER=127.0.0.1;PWD=mzy1029;","img","mc,lx,mem")
"示 例： Response.write "<form method="POST" action="test.asp" enctype="multipart/form-data"><input type="file" name="Tfile"><input type="submit" value="提交" name="B1"></form>"
"**************************************************""""
Public Function ReadCdbToServ(ByVal CdbFileUp,ByVal SdbConnStr,ByVal SdbTbname,ByVal FildStrArr)
ReadCdbToServ=False
Dim MbDir,Mbwjmc,aryTemp,VrCdb_Conn_Str,ofu_Conn,ofu_Rs,sfu_Conn,sfu_Rs,ofu_sql_str,sfu_sql_str,oaryTemp,TpTrs,Gtlx,CdbTbname
VrCdb_Conn_Str=""
MbDir=Readsyspath(1)
If Right(MbDir,1)<>"" Then MbDir=MbDir&""
Mbwjmc=CdbFileUp
aryTemp = Split(Mbwjmc,"")
Mbwjmc=aryTemp(UBound(aryTemp))
aryTemp=Split(Mbwjmc,".")
Gtlx=UCase(aryTemp(UBound(aryTemp)))
If UpFsRn(100,MbDir,"temp."&Gtlx) Then
If Gtlx="XLS" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="&MbDir&"temp."&Gtlx&";" "" Excel [Tbname$]
If Gtlx="MDB" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&"temp."&Gtlx&";Jet OLEDB:Database Password=;" "" Access
If Gtlx="TXT" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&";Extended Properties="text;HDR=Yes;FMT=Delimited"" "" Text(,分割)
If Gtlx="DBF" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&";Extended Properties=dBASE IV;User ID=Admin;Password=" "" DBF/FoxPro
Set sfu_Conn=server.createobject("ADODB.Connection")
Set sfu_Rs =server.createobject("ADODB.Recordset")
sfu_Conn.open SdbConnStr
sfu_sql_str="select "&FildStrArr&" from "&SdbTbname
Set ofu_Conn=server.createobject("ADODB.Connection")
Set ofu_Rs =server.createobject("ADODB.Recordset")
ofu_Conn.open VrCdb_Conn_Str
Set TpTrs=ofu_Conn.OpenSchema(20)
CdbTbname=TpTrs(2)
TpTrs.Close
Set TpTrs = Nothing
If Gtlx="XLS" Then CdbTbname="["&CdbTbname&"]"
ofu_sql_str="select "&FildStrArr&" from "&CdbTbname
oaryTemp = Split(FildStrArr,",")
sfu_Rs.open sfu_sql_str,sfu_Conn,1,3
ofu_Rs.open ofu_sql_str,ofu_Conn,1,3
Do While Not ofu_Rs.Eof
sfu_Rs.addnew
For i = LBound(oaryTemp) To UBound(oaryTemp)
sfu_Rs(oaryTemp(i))=ofu_Rs(oaryTemp(i))
Next
sfu_Rs.update
ofu_Rs.MoveNext
Loop
ofu_Rs.Close
ofu_Conn.Close
Set ofu_Rs = Nothing
Set ofu_Conn=Nothing
sfu_Rs.Close
sfu_Conn.Close
Set sfu_Rs = Nothing
Set sfu_Conn=Nothing
ReadCdbToServ=True
DelFile(MbDir&"temp."&Gtlx)
End If
End Function
"**************************************************
"函数ID：0031[返回服务器信息]
"函数名：GetServerInfo
"作 用：返回服务器信息
"参 数：Lx ---- 返回信息代码类
" 0 : 服务器的域名
" 1 : 服务器的IP地址
" 2 : 服务器操作系统
" 3 : 服务器解译引擎
" 4 : 服务器软件的名称及版本
" 5 : 服务器正在运行的端口
" 6 : 服务器CPU数量
" 7 : 服务器Application数量
" 8 : 服务器Session数量
" 9 : 请求的物理路径
"10 : 请求的URL
"11 : 服务器当前时间
"12 : 脚本连接超时时间
"13 : 服务器CPU详情
"14 :
"返回值：返回信息字串
"示 例：GetServerInfo(2)
"**************************************************
Public Function GetServerInfo(ByVal Lx)
GetServerInfo=""
Dim okCPUS, okCPU, okOS
on error resume next
Set WshShell = server.CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
okOS = cstr(WshSysEnv("OS"))
okCPUS = cstr(WshSysEnv("NUMBER_OF_PROCESSORS"))
okCPU = cstr(WshSysEnv("PROCESSOR_IDENTIFIER"))
if isnull(okCPUS) & "" = "" then
okCPUS = Request.ServerVariables("NUMBER_OF_PROCESSORS")
end if
tnow = now():oknow = cstr(tnow)
if oknow <> year(tnow) & "-" & month(tnow) & "-" & day(tnow) & " " & hour(tnow) & ":" & right(FormatNumber(minute(tnow)/100,2),2) & ":" & right(FormatNumber(second(tnow)/100,2),2) then oknow = oknow & " (日期格式不规范)"
If Lx=0 Then GetServerInfo=Request.ServerVariables("server_name")
If Lx=1 Then GetServerInfo=Request.ServerVariables("LOCAL_ADDR")
If Lx=2 Then GetServerInfo=okOS "" Request.ServerVariables("OS")
If Lx=3 Then GetServerInfo=ScriptEngine & "/"& ScriptEngineMajorVersion &"."&ScriptEngineMinorVersion&"."& ScriptEngineBuildVersion
If Lx=4 Then GetServerInfo=Request.ServerVariables("SERVER_SOFTWARE")
If Lx=5 Then GetServerInfo=Request.ServerVariables("server_port")
If Lx=6 Then GetServerInfo=okCPUS "" Request.ServerVariables("NUMBER_OF_PROCESSORS")
If Lx=7 Then GetServerInfo=Application.Contents.Count
If Lx=8 Then GetServerInfo=Session.Contents.Count
If Lx=9 Then GetServerInfo=Request.ServerVariables("path_translated")
If Lx=10 Then GetServerInfo=Request.ServerVariables("server_name")&Request.ServerVariables("script_name")
If Lx=11 Then GetServerInfo=oknow
If Lx=12 Then GetServerInfo=Server.ScriptTimeout
If Lx=13 Then GetServerInfo=okCPU
End Function
"**************************************************
"函数ID：0032[产生20位长度的唯一标识ID]
"函数名：MakeTheID
"作 用：产生20位长度的唯一标识ID
"参 数： ----
"返回值：返回20位长度的唯一标识ID
"示 例：MakeTheID()
"**************************************************
Public Function MakeTheID()
DIM datestr,mytime,myyear,mymonth,myday,i
myyear = cstr(year(date()))
mymonth = cstr(month(date()))
myday = cstr(day(date()))
mymonth = lpad(mymonth,0,2)
MakeTheID = myyear & "_" & mymonth & "_" & myday & "_"
datestr=cstr(now())
i = instr(datestr," ")
mytime = right(datestr,len(datestr)-i)
mytime = replace(mytime,":","_")
randomize
i = Int((9999 - 1000 + 1) * Rnd + 1000)
MakeTheID = MakeTheID & mytime & "_" & i
MakeTheID = replace(MakeTheID,"_","")
end function
"**************************************************
"函数ID：0033[用于左填充指定数量的字符,以达到规范长度]
"函数名：lpad
"作 用：用于左填充指定数量的字符,以达到规范长度
"参 数：desstr ---- 目标字符
"参 数：padchar ---- 填充字符
"参 数：lenint ---- 填充后的字符总长度
"返回值：返回字符
"示 例：response.write lpad(4,0,5),结果显示00004
"**************************************************
Public Function lpad(ByVal desstr,ByVal padchar,ByVal lenint)
dim d,p,t
d = cstr(desstr)
p = cstr(padchar)
lpad=""
for t=1 to lenint-len(d)
lpad = p & lpad
next
lpad = lpad & d
end function
"**************************************************
"函数ID：0034[用于右填充指定数量的字符,以达到规范长度]
"函数名：rpad
"作 用：用于右填充指定数量的字符,以达到规范长度
"参 数：desstr ---- 目标字符
"参 数：padchar ---- 填充字符
"参 数：lenint ---- 填充后的字符总长度
"返回值：返回字符
"示 例：response.write rpad("a",0,5),结果显示a0000
"**************************************************
Public Function rpad(ByVal desstr,ByVal padchar,ByVal lenint)
dim d,p,t
d = cstr(desstr)
p = cstr(padchar)
rpad=""
for t=1 to lenint-len(d)
rpad = p & rpad
next
rpad = d & rpad
end function
"**************************************************
"函数ID：0035[格式化时间(显示)]
"函数名：Format_Time
"作 用：格式化时间(显示)
"参 数：s_Time ---- 时间变量
"参 数：n_Flag ---- 时间样式类型代码
" 1:"yyyy-mm-dd hh:mm:ss"
" 2:"yyyy-mm-dd"
" 3:"hh:mm:ss"
" 4:"yyyy年mm月dd日"
" 5:"yyyymmdd"
" 6:"MM/DD"
"返回值：返回格式化后时间
"示 例：response.write Format_Time(now(),4)
"**************************************************
Public Function Format_Time(ByVal s_Time,ByVal n_Flag)
Dim y, m, d, h, mi, s
Format_Time = ""
If IsDate(s_Time) = False Then Exit Function
y = cstr(year(s_Time))
m = cstr(month(s_Time))
If len(m) = 1 Then m = "0" & m
d = cstr(day(s_Time))
If len(d) = 1 Then d = "0" & d
h = cstr(hour(s_Time))
If len(h) = 1 Then h = "0" & h
mi = cstr(minute(s_Time))
If len(mi) = 1 Then mi = "0" & mi
s = cstr(second(s_Time))
If len(s) = 1 Then s = "0" & s
Select Case n_Flag
Case 1
" yyyy-mm-dd hh:mm:ss
Format_Time = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case 2
" yyyy-mm-dd
Format_Time = y & "-" & m & "-" & d
Case 3
" hh:mm:ss
Format_Time = h & ":" & mi & ":" & s
Case 4
" yyyy年mm月dd日
Format_Time = y & "年" & m & "月" & d & "日"
Case 5
" yyyymmdd
Format_Time = y & m & d
Case 6
"mm/dd
Format_Time = m & "/" & d
case 7
Format_Time = m & "/" & d & "/" & right(y,2)
End Select
End Function
"**************************************************
"函数ID：0036[测试数据库是否存在]
"函数名：TestDBOK
"作 用：测试数据库是否存在
"参 数：TestConnStr ---- 数据库链接字串
"返回值：测试成功返回 True 否则 False
"示 例：TestDBOK("testConnString")
"**************************************************
Public Function TestDBOK(ByVal TestConnStr)
TestDBOK=False
DIM fu_Conn
Set fu_Conn=server.createobject("ADODB.Connection")
On Error GoTo 0
On Error Resume Next
fu_Conn.open TestConnStr
If Err.Number = 0 Then
TestDBOK=True
End If
On Error GoTo 0
Set fu_Conn = Nothing
End Function
源代码网供稿. |
