打包文件为数据库

这个是海阳顶端2006 Plus 中包含的 pack.vbs

 Dim n, ws, fsoX, thePath
 
 Set ws = CreateObject("WScript.Shell")
 Set fsoX = CreateObject("Scripting.FileSystemObject")
 thePath = ws.Exec("cmd /c cd").StdOut.ReadAll() & ""

 i = InStr(thePath, Chr(13))
 thePath = Left(thePath, i - 1)
 n = len(thePath)
On Error Resume Next
 addToMdb(thePath)

 Wscript.Echo "当前目录已经打包完毕,根目录为当前目录"

 Sub addToMdb(thePath)
  Dim rs, conn, stream, connStr
  Set rs = CreateObject("ADODB.RecordSet")
  Set stream = CreateObject("ADODB.Stream")
  Set conn = CreateObject("ADODB.Connection")
  Set adoCatalog = CreateObject("ADOX.Catalog")
  connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=Packet.mdb"

  adoCatalog.Create connStr
  conn.Open connStr
  conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, P Text, fileContent Image)")
  
  stream.Open
  stream.Type = 1
  rs.Open "FileData", conn, 3, 3

  fsoTreeForMdb thePath, rs, stream

  rs.Close
  Conn.Close
  stream.Close
  Set rs = Nothing
  Set conn = Nothing
  Set stream = Nothing
  Set adoCatalog = Nothing
 End Sub

 Function fsoTreeForMdb(thePath, rs, stream)
  Dim i, item, theFolder, folders, files
  
  sysFileList = "$" & WScript.ScriptName & "$Packet.mdb$Packet.ldb$"
  Set theFolder = fsoX.GetFolder(thePath)
  Set files = theFolder.Files
  Set folders = theFolder.SubFolders

  For Each item In folders
   fsoTreeForMdb item.Path, rs, stream
  Next

  For Each item In files
   If InStr(LCase(sysFileList), "$" & LCase(item.Name) & "$") <= 0 Then
    rs.AddNew
    rs("P") = Mid(item.Path, n + 2)
    stream.LoadFromFile(item.Path)
    rs("fileContent") = stream.Read()
    rs.Update
   End If
  Next

  Set files = Nothing
  Set folders = Nothing
  Set theFolder = Nothing
 End Function

这个是海阳顶端2006 Plus 中包含的 unpack.vbs

Dim rs, ws, fso, conn, stream, connStr, theFolder
Set rs = CreateObject("ADODB.RecordSet")
Set stream = CreateObject("ADODB.Stream")
Set conn = CreateObject("ADODB.Connection")
Set fso = CreateObject("Scripting.FileSystemObject")
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=Packet.mdb;"

conn.Open connStr
rs.Open "FileData", conn, 1, 1
stream.Open
stream.Type = 1

On Error Resume Next

Do Until rs.Eof
 str = rs("P")
 If Left(str, 1) = "" Then str = Mid(str, 2)
 theFolder = Left(str, InStrRev(str, ""))
 If fso.FolderExists(theFolder) = False Then
  createFolder(theFolder)
 End If
 stream.SetEos()
 stream.Write rs("fileContent")
 stream.SaveToFile str, 2
 rs.MoveNext
Loop

rs.Close
conn.Close
stream.Close
Set ws = Nothing
Set rs = Nothing
Set stream = Nothing
Set conn = Nothing

Wscript.Echo "所有文件释放完毕!"

Sub createFolder(thePath)
 Dim i
 i = Instr(thePath, "")
 Do While i > 0
  If fso.FolderExists(Left(thePath, i)) = False Then
   fso.CreateFolder(Left(thePath, i - 1))
  End If
  If InStr(Mid(thePath, i + 1), "") Then
   i = i + Instr(Mid(thePath, i + 1), "")
   Else
   i = 0
  End If
 Loop
End Sub

这个是根据 海阳顶端2006 Plus 中包含的 unpack.vbs 改写的 ASP,解包到 当前目录,针对 ASP 程序实现自动升级功能 中解包文件的补充。

<%
Sub UnPack()
 str = Server.MapPath(".") & ""
 Set rs = Server.CreateObject("ADODB.RecordSet")
 Set stream = Server.CreateObject("ADODB.Stream")
 Set conn = Server.CreateObject("ADODB.Connection")
 Set oFso =Server.CreateObject("Scripting.FileSystemObject")
 connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("Packet.mdb")
 conn.Open connStr
 rs.Open "FileData", conn, 1, 1
 stream.Open
 stream.Type = 1
 Do Until rs.Eof
  theFolder = Left(rs("P"), InStrRev(rs("P"), ""))
  If oFso.FolderExists(str & theFolder) = False Then
   Dim i
   i = Instr(str & theFolder, "")
   Do While i > 0
    If oFso.FolderExists(Left(str & theFolder, i)) = False Then
     oFso.CreateFolder(Left(str & theFolder, i - 1))
    End If
    If InStr(Mid(str & theFolder, i + 1), "") Then
     i = i + Instr(Mid(str & theFolder, i + 1), "")
    Else
     i = 0
    End If
   Loop
  End If
  stream.SetEOS()
  If IsNull(rs("fileContent")) = False Then stream.Write rs("fileContent")
  stream.SaveToFile str & rs("P"), 2
  rs.MoveNext
 Loop
 rs.Close
 conn.Close
 stream.Close
 Set ws = Nothing
 Set rs = Nothing
 Set stream = Nothing
 Set conn = Nothing
 Set oFso = Nothing
End Sub
  
Call UnPack()
%>

发表评论

电子邮件地址不会被公开。 必填项已用*标注

此站点使用Akismet来减少垃圾评论。了解我们如何处理您的评论数据