ASP函數庫 - 中央論壇 - CENTER BBS

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
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 "<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
Next
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
End If
Next
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="[url=http://]http://"&Request("SERVER_NAME")&Request("PATH_INFO[/url]")
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("(\<.[^\<]*\>)","<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,"")
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
strC
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 "<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'>"&TempBsXX&"</td>" & vbCrlf
Response.write "</tr>" & vbCrlf
End If
Next
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 ---- 資料庫用戶密碼
'返回值：鏈接字串
'示例：[url]http://www.knowsky.com/[/url]
'**************************************************
Public Function GetConnStr(ByVal Lx,ByVal Dbiporpath,ByVal Dbmc,ByVal Dbuid,ByVal Dbupwd)
GetC
If Lx=0 Then
If Right(Dbiporpath,1)<>"\" Then Dbiporpath=Dbiporpath & "\"
GetC&Dbiporpath&Dbmc&";Jet OLEDB:Database Password="&Dbupwd&";"
End If
If Lx=1 Then
GetC&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))
Next
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.C&Trim(fu_Rs(Dlx))
Response.Flush
Response.BinaryWrite fu_Rs(Ddata)
Response.End
End If
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
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
'**************************************************
'函數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
'**************************************************
'函數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(/<[url=file://%3F/?xml[^]\\?\?xml[^>]*>/gi[/url]、'') ;" & 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 "}" & 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)))
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.C
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 （所在可用字符如[email=「90!@#$%]「90!@#$%[/email]」）
'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 = "[email=1234567890!@#$%^&*()[];]1234567890!@#$%^&*()[];',./{}:?`~-=\_+|abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ[/email]"
passNumber = "1234567890"
passSpecial = "[email=!@#$%^&*()[];]!@#$%^&*()[];',./{}:?`~-=\[/email]_+|"
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
%>

複製代碼