ASP函數庫(全部可以直接調用，非常方便) 5

'**************************************************''''
'函數ID：0028[取得映像的類型|寬|高]
'函數名：GetImageDx
'作 用：取得映像的類型|寬|高
'參 數：filepath ---- 檔案路徑及檔案命名
'傳回值："類型|寬|高"
'**************************************************''''
Public Function GetImageDx(ByVal filepath)
DIM Tempsm,NBxx,WJXX(3)
SET Tempsm = Server.CreateObject("ADODB.Stream")
Tempsm.Mode=3
Tempsm.Type=1
Tempsm.Open
Tempsm.LoadFromFile filepath
NBxx=Hex(BinVal(Tempsm.Read(3)))
WJXX(0)=NBxx
WJXX(1)="0"
WJXX(2)="0"
If NBxx="464947" Then
WJXX(0)="GIF"
Tempsm.Read(3)
WJXX(1)=BinVal(Tempsm.Read(2))
WJXX(2)=BinVal(Tempsm.Read(2))
End If
If NBxx="FFD8FF" Then
WJXX(0)="JPG"
do
do: p1=binVal(Tempsm.Read(1)): loop while p1=255 and not Tempsm.EOS
if p1>191 and p1<196 then exit do else Tempsm.Read(binval2(Tempsm.Read(2))-2)
do:p1=binVal(Tempsm.Read(1)):loop while p1<255 and not Tempsm.EOS
loop while true
Tempsm.Read(3)
WJXX(2)=binval2(Tempsm.Read(2))
WJXX(1)=binval2(Tempsm.Read(2))
End If
If Mid(NBxx,3)="4D42" Then
Tempsm.Read(15)
WJXX(0)="BMP"
WJXX(1)=binval(Tempsm.Read(4))
WJXX(2)=binval(Tempsm.Read(4))
End If
If NBxx="4E5089" Then
WJXX(0)="PNG"
Tempsm.Read(15)
WJXX(1)=BinVal2(Tempsm.Read(2))
Tempsm.Read(2)
WJXX(2)=BinVal2(Tempsm.Read(2))
End If
If NBxx="535743" Then
WJXX(0)="SWF"
Tempsm.Read(5)
binData=Tempsm.Read(1)
sConv=Num2Str(ascb(binData),2 ,8)
nBits=Str2Num(left(sConv,5),2)
sConv=mid(sConv,6)
while(len(sConv)<nBits*4)
binData=Tempsm.Read(1)
sConv=sConv&Num2Str(ascb(binData),2 ,8)
wend
WJXX(1)=int(abs(Str2Num(mid(sConv,1*nBits+1,nBits),2)-Str2Num(mid(sConv,0*nBits+1,nBits),2))/20)
WJXX(2)=int(abs(Str2Num(mid(sConv,3*nBits+1,nBits),2)-Str2Num(mid(sConv,2*nBits+1,nBits),2))/20)
End If
Tempsm.Close
SET Tempsm=nothing
GetImageDx = WJXX(0)&"|"&WJXX(1)&"|"&WJXX(2)
End Function
Function BinVal(bin)
dim ret
ret = 0
for i = lenb(bin) to 1 step -1
ret = ret *256 + ascb(midb(bin,i,1))
next
BinVal=ret
End Function
Function BinVal2(bin)
dim ret
ret = 0
for i = 1 to lenb(bin)
ret = ret *256 + ascb(midb(bin,i,1))
next
BinVal2=ret
End Function
Function Str2Num(str,base)
dim ret
ret = 0
for i=1 to len(str)
ret = ret *base + cint(mid(str,i,1))
next
Str2Num=ret
End Function
Function Num2Str(num,base,lens)
dim ret
ret = ""
while(num>=base)
ret = (num mod base) & ret
num = (num - num mod base)/base
wend
Num2Str = right(string(lens,"0") & num & ret,lens)
End Function
'**************************************************''''
'函數ID：0029[將本地檔案進行二進位分析，並儲存到伺服器的指定目錄下]
'函數名：TxtBinInfo
'作 用：將本地檔案進行二進位分析，並儲存到伺服器的指定目錄下
'參 數：Filestr ---- 被分析檔案路徑及檔案命名
'參 數：WebSvFile ---- 分析資訊儲存檔案路徑及檔案命名
'傳回值：成功返回 True 否則 False
'示 例： TempSj=Request.Form("Tfile")
'示 例： If Trim(TempSj)<>"" Then CALL TxtBinInfo(TempSj,"d:\aa.txt")
'示 例： Response.write "<form method='POST' action='test.asp'><input type='file' name='Tfile'><input type='submit' value='提交' name='B1'></form>"
'**************************************************''''
Public Function TxtBinInfo(ByVal Filestr,ByVal WebSvFile)
TxtBinInfo=False
DIM Wtempxx
Wtempxx=""
SET Tempsm = Server.CreateObject("ADODB.Stream")
Tempsm.Mode=3
Tempsm.Type=1
Tempsm.Open
Tempsm.LoadFromFile (Filestr)
tempRedImg=Tempsm.Read
for i = lenb(tempRedImg) to 1 step -1
Wtempxx=Wtempxx& "地址號：" &i &"地址十六進位："& Hex(ascb(midb(tempRedImg,i,1))) &" 十進位："&ascb(midb(tempRedImg,i,1))&vbCrlf
next
Wtempxx=Wtempxx&vbCrlf&"大小："&lenb(tempRedImg)&"位元組 該檔案名稱為：" &Filestr
Set M_fso = CreateObject("Scripting.FileSystemObject")
Set FnameN= M_fso.OpenTextFile(WebSvFile,2,True)
FnameN.Write Wtempxx
FnameN.Close
Set M_fso = Nothing
Tempsm.Close
SET Tempsm=nothing
TxtBinInfo=True
End Function
'**************************************************''''
'函數ID：0030[將本機資料表或庫上傳並匯入到伺服器資料庫的表中]
'函數名：ReadCdbToServ
'作 用：將本機資料表或庫上傳並匯入到伺服器資料庫的表中
'參 數：CdbFileUp ---- 被上傳的庫或表檔案路徑及檔案名稱
'參 數：SdbConnStr ---- 伺服器資料庫連結字串
'參 數：SdbTbname ---- 伺服器將開啟的表名
'參 數：FildStrArr ---- 匯入的資料欄位串(各欄位用","隔開)
'傳回值：成功返回 True 否則 False
'注可匯入的檔案類型有(0:Excel 1:Access 2:Text 3:DBF/FoxPro)
'註：Excel 的表為Sheet名稱，文本及DBF/FoxPro的表名為資料檔案的全名，如 aa.txt 或 aa.dbf
'註：Text 文本資料表是以","為分隔的格式 ，重點：被匯入的資料庫只能包含一個表，並且匯入的欄位應和伺服器資料庫的表相一致
'示 例： CALL ReadCdbToServ(TempSj,"DRIVER=SQL Server;UID=sa;DATABASE=temp;SERVER=127.0.0.1;PWD=mzy1029;","img","mc,lx,mem")
'示 例： Response.write "<form method='POST' action='test.asp' enctype='multipart/form-data'><input type='file' name='Tfile'><input type='submit' value='提交' name='B1'></form>"
'**************************************************''''
Public Function ReadCdbToServ(ByVal CdbFileUp,ByVal SdbConnStr,ByVal SdbTbname,ByVal FildStrArr)
ReadCdbToServ=False
Dim MbDir,Mbwjmc,aryTemp,VrCdb_Conn_Str,ofu_Conn,ofu_Rs,sfu_Conn,sfu_Rs,ofu_sql_str,sfu_sql_str,oaryTemp,TpTrs,Gtlx,CdbTbname
VrCdb_Conn_Str=""
MbDir=Readsyspath(1)
If Right(MbDir,1)<>"\" Then MbDir=MbDir&"\"
Mbwjmc=CdbFileUp
aryTemp = Split(Mbwjmc,"\")
Mbwjmc=aryTemp(UBound(aryTemp))
aryTemp=Split(Mbwjmc,".")
Gtlx=UCase(aryTemp(UBound(aryTemp)))
If UpFsRn(100,MbDir,"temp."&Gtlx) Then
If Gtlx="XLS" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="&MbDir&"temp."&Gtlx&";" '' Excel [Tbname$]
If Gtlx="MDB" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&"temp."&Gtlx&";Jet OLEDB:Database Password=;" '' Access
If Gtlx="TXT" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&";Extended Properties='text;HDR=Yes;FMT=Delimited'" '' Text(,分割)
If Gtlx="DBF" Then VrCdb_Conn_Str ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&MbDir&";Extended Properties=dBASE IV;User ID=Admin;Password=" '' DBF/FoxPro
Set sfu_Conn=server.createobject("ADODB.Connection")
Set sfu_Rs =server.createobject("ADODB.Recordset")
sfu_Conn.open SdbConnStr
sfu_sql_str="select "&FildStrArr&" from "&SdbTbname
Set ofu_Conn=server.createobject("ADODB.Connection")
Set ofu_Rs =server.createobject("ADODB.Recordset")
ofu_Conn.open VrCdb_Conn_Str
Set TpTrs=ofu_Conn.OpenSchema(20)
CdbTbname=TpTrs(2)
TpTrs.Close
Set TpTrs = Nothing
If Gtlx="XLS" Then CdbTbname="["&CdbTbname&"]"
ofu_sql_str="select "&FildStrArr&" from "&CdbTbname
oaryTemp = Split(FildStrArr,",")
sfu_Rs.open sfu_sql_str,sfu_Conn,1,3
ofu_Rs.open ofu_sql_str,ofu_Conn,1,3
Do While Not ofu_Rs.Eof
sfu_Rs.addnew
For i = LBound(oaryTemp) To UBound(oaryTemp)
sfu_Rs(oaryTemp(i))=ofu_Rs(oaryTemp(i))
Next
sfu_Rs.update
ofu_Rs.MoveNext
Loop
ofu_Rs.Close
ofu_Conn.Close
Set ofu_Rs = Nothing
Set ofu_Conn=Nothing
sfu_Rs.Close
sfu_Conn.Close
Set sfu_Rs = Nothing
Set sfu_Conn=Nothing
ReadCdbToServ=True
DelFile(MbDir&"temp."&Gtlx)
End If
End Function
'**************************************************
'函數ID：0031[返回伺服器資訊]
'函數名：GetServerInfo
'作 用：返回伺服器資訊
'參 數：Lx ---- 返回資訊代碼類
' 0 : 伺服器的網域名稱
' 1 : 伺服器的IP地址
' 2 : 伺服器作業系統
' 3 : 伺服器解譯引擎
' 4 : 伺服器軟體的名稱及版本
' 5 : 伺服器正在啟動並執行連接埠
' 6 : 伺服器CPU數量
' 7 : 伺服器Application數量
' 8 : 伺服器Session數量
' 9 : 請求的實體路徑
'10 : 請求的URL
'11 : 伺服器目前時間
'12 : 指令碼連線逾時時間
'13 : 伺服器CPU詳情
'14 :
'傳回值：返回資訊字串
'示 例：GetServerInfo(2)
'**************************************************
Public Function GetServerInfo(ByVal Lx)
GetServerInfo=""
Dim okCPUS, okCPU, okOS
on error resume next
Set WshShell = server.CreateObject("WScript.Shell")
Set WshSysEnv = WshShell.Environment("SYSTEM")
okOS = cstr(WshSysEnv("OS"))
okCPUS = cstr(WshSysEnv("NUMBER_OF_PROCESSORS"))
okCPU = cstr(WshSysEnv("PROCESSOR_IDENTIFIER"))
if isnull(okCPUS) & "" = "" then
okCPUS = Request.ServerVariables("NUMBER_OF_PROCESSORS")
end if
tnow = now():oknow = cstr(tnow)
if oknow <> year(tnow) & "-" & month(tnow) & "-" & day(tnow) & " " & hour(tnow) & ":" & right(FormatNumber(minute(tnow)/100,2),2) & ":" & right(FormatNumber(second(tnow)/100,2),2) then oknow = oknow & " (日期格式不規範)"
If Lx=0 Then GetServerInfo=Request.ServerVariables("server_name")
If Lx=1 Then GetServerInfo=Request.ServerVariables("LOCAL_ADDR")
If Lx=2 Then GetServerInfo=okOS '' Request.ServerVariables("OS")
If Lx=3 Then GetServerInfo=ScriptEngine & "/"& ScriptEngineMajorVersion &"."&ScriptEngineMinorVersion&"."& ScriptEngineBuildVersion
If Lx=4 Then GetServerInfo=Request.ServerVariables("SERVER_SOFTWARE")
If Lx=5 Then GetServerInfo=Request.ServerVariables("server_port")
If Lx=6 Then GetServerInfo=okCPUS '' Request.ServerVariables("NUMBER_OF_PROCESSORS")
If Lx=7 Then GetServerInfo=Application.Contents.Count
If Lx=8 Then GetServerInfo=Session.Contents.Count
If Lx=9 Then GetServerInfo=Request.ServerVariables("path_translated")
If Lx=10 Then GetServerInfo=Request.ServerVariables("server_name")&Request.ServerVariables("script_name")
If Lx=11 Then GetServerInfo=oknow
If Lx=12 Then GetServerInfo=Server.ScriptTimeout
If Lx=13 Then GetServerInfo=okCPU
End Function
'**************************************************
'函數ID：0032[產生20位長度的唯一標識ID]
'函數名：MakeTheID
'作 用：產生20位長度的唯一標識ID
'參 數： ----
'傳回值：返回20位長度的唯一標識ID
'示 例：MakeTheID()
'**************************************************
Public Function MakeTheID()
DIM datestr,mytime,myyear,mymonth,myday,i
myyear = cstr(year(date()))
mymonth = cstr(month(date()))
myday = cstr(day(date()))
mymonth = lpad(mymonth,0,2)
MakeTheID = myyear & "_" & mymonth & "_" & myday & "_"
datestr=cstr(now())
i = instr(datestr," ")
mytime = right(datestr,len(datestr)-i)
mytime = replace(mytime,":","_")
randomize
i = Int((9999 - 1000 + 1) * Rnd + 1000)
MakeTheID = MakeTheID & mytime & "_" & i
MakeTheID = replace(MakeTheID,"_","")
end function
'**************************************************
'函數ID：0033[用於左填充指定數量的字元,以達到規範長度]
'函數名：lpad
'作 用：用於左填充指定數量的字元,以達到規範長度
'參 數：desstr ---- 目標字元
'參 數：padchar ---- 填充字元
'參 數：lenint ---- 填充後的字元總長度
'傳回值：返回字元
'示 例：response.write lpad(4,0,5),結果顯示00004
'**************************************************
Public Function lpad(ByVal desstr,ByVal padchar,ByVal lenint)
dim d,p,t
d = cstr(desstr)
p = cstr(padchar)
lpad=""
for t=1 to lenint-len(d)
lpad = p & lpad
next
lpad = lpad & d
end function
'**************************************************