qq音乐 sq:ASP常用函数库3

'**************************************************''''
  '函数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
  '**************************************************''''
  '函数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 "

"
  '**************************************************''''
  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