Asp无组件上传,可打包为dll

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "FileUp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim FormData, FormSize, stream, AllowExts, RootPath, maxFileSize, errMsg, fileErr, AllFile
Private MyServer As Server
Private MyRequest As Request
Private MyResponse As Response
Private MySession As Session
Private MyScriptContext As ScriptingContext
Public Function SetAllowExts(exts)
  AllowExts = exts
End Function
Public Function SetRootPath(RP)
  RootPath = RP
  If Right(RootPath, 1) <> "/" Then RootPath = RootPath & "/"
End Function
Public Function SetmaxFileSize(FileSize)
  maxFileSize = FileSize
End Function
Public Function GetError()
  Dim allerr
  allerr = ""
  If fileErr <> "" Or errMsg <> "" Then allerr = "发生如下错误！\n\n"
  If fileErr <> "" Then allerr = allerr & fileErr
  If errMsg <> "" Then allerr = "\n\n" & allerr & errMsg
  GetError = allerr
End Function
Public Function GetAllFiles()
  If AllFile <> "" And Right(AllFile, 1) = "," Then
    GetAllFiles = Mid(AllFile, 1, Len(AllFile) - 1)
  End If
End Function
Public Sub OnStartPage(NowPageContext As ScriptingContext)
  Set MyScriptContext = NowPageContext
  Set MyServer = MyScriptContext.Server
  Set MyRequest = MyScriptContext.Request
  Set MyResponse = MyScriptContext.Response
  Set MySession = MyScriptContext.Session
End Sub
Public Sub OnEndPage()
Set MyScriptContext = Nothing
Set MyRequest = Nothing
Set MyServer = Nothing
Set MyResponse = Nothing
Set MySession = Nothing
End Sub
Private Sub Class_Initialize()
errMsg = ""
fileErr = ""
AllFile = ""
maxFileSize = 200
RootPath = "uploadfiles/"
If Right(RootPath, 1) <> "/" Then RootPath = RootPath & "/"
AllowExts = "gif|jpg|bmp|png"
End Sub
Private Sub Class_Terminate()
  Err.Clear
End Sub
Public Function GetData()
  Dim sfilename, FileName, CLStr, DivStr, DivStrLen, fileExt, DataStart, DataSize, _
     fileCount, headstart, headend, filenamestart
  '字符串filename="的二进制表示
  FormSize = MyRequest.TotalBytes
  If FormSize < 0 Then
    errMsg = "未上传文件"
    Exit Function
  End If
  On Error Resume Next '防止超过IIS最大文件限制
  FormData = MyRequest.BinaryRead(FormSize)
  If Err <> 0 Then
    errMsg = "IIS文件大小限制，请联系管理员解决问题！"
  Else
    On Error GoTo 0 '取消容错
    filenamestart = ChrB(102) & ChrB(105) & ChrB(108) & ChrB(101) & ChrB(110) & ChrB(97) _
       & ChrB(109) & ChrB(101) & ChrB(61) & ChrB(34)
     fileCount = 0
    Set stream = MyServer.CreateObject("adodb.stream")
    stream.Type = 1
    stream.Mode = 3
    stream.Open
    stream.Write FormData
    CLStr = ChrB(13) & ChrB(10)
        DivStr = LeftB(FormData, InStrB(FormData, CLStr) - 1)
    DivStrLen = LenB(DivStr)
  
    headstart = InStrB(DivStrLen + 2, FormData, filenamestart) + 9
    headend = InStrB(headstart, FormData, CLStr) - 2
    '文件数据的开始用两对回车换行符分隔
    '3是两对回车换行符的长度中的剩余3个字节,因为instrb返回了两对回车换行符第一字节的文字,一定要注意此处
    '注意此处为3不能为4，要不你就等着哭吧，吗的，老子就是用4结果调试了半天才搞定，我日,就差一个字节都要老命
    DataStart = InStrB(headend, FormData, CLStr & CLStr) + 3
    DataSize = InStrB(DataStart + 1, FormData, DivStr) - DataStart - 3 '可以多取数据，但不能少取，要不无法显示图片
    While headstart > 9 And DataSize > 0
     fileCount = fileCount + 1
     fileExt = getExt(headstart, headend, sfilename)
     If Not checkFileSize(DataSize) Then
      fileErr = fileErr & sfilename & "上传失败，文件大小超过" & maxFileSize & "KB！\n"
     ElseIf Not checkExt(fileExt) Then
      fileErr = fileErr & sfilename & "上传失败，文件类型 " & fileExt & " 不允许上传！\n"
     Else
      FileName = getFileName(fileExt, fileCount)
      Call saveFile(DataStart, DataSize, FileName, sfilename)
     End If
     '计算下一个文件位置
     headstart = InStrB(DataStart + DataSize + DivStrLen + 2, FormData, filenamestart) + 9
     headend = InStrB(headstart, FormData, CLStr) - 2
     DataStart = InStrB(headend, FormData, CLStr & CLStr) + 3
     DataSize = InStrB(DataStart + 1, FormData, DivStr) - DataStart - 3
    Wend
    stream.Close
    Set stream = Nothing
  End If
End Function
Private Function getExt(ByVal s, ByVal e, sfn)
  Dim ExtStream, lineStr, fileExt
  Set ExtStream = MyServer.CreateObject("adodb.stream")
  ExtStream.Type = 1
  ExtStream.Mode = 3
  stream.Position = s
  ExtStream.Open
  stream.CopyTo ExtStream, e - s
  ExtStream.Position = 0
  ExtStream.Type = 2
  ExtStream.Charset = "gb2312"
  lineStr = ExtStream.ReadText '获取文件的客户端路径
  ExtStream.Close
  Set ExtStream = Nothing
  sfn = Mid(lineStr, InStrRev(lineStr, "\") + 1)
  fileExt = LCase(Replace(Mid(lineStr, InStrRev(lineStr, ".") + 1), """", ""))
  getExt = fileExt
End Function

Private Function checkExt(fileExt)
  Dim exts, ext
  exts = Split(AllowExts, "|")
  For Each ext In exts
    If ext = fileExt Then
      checkExt = True
      Exit Function
    End If
  Next
  checkExt = False
End Function

Private Function checkFileSize(ByVal size)
   If size > maxFileSize * 1024 Then
     checkFileSize = False
   Else
     checkFileSize = True
   End If
End Function

Private Function getFileName(fileExt, i)
  'i为上传的第i个文件
  '使用该变量为了防止服务器处理过快使用同一个时间生成的名字覆盖别的文件
  getFileName = Replace(Replace(Replace(Now(), " ", ""), ":", ""), "-", "") & i & "." & fileExt
End Function

Private Function saveFile(ByVal s, ByVal size, ByVal FileName, sfn)
  On Error Resume Next
  Dim tstream, FilePath
  FilePath = MyServer.MapPath(RootPath & FileName)
  Set tstream = MyServer.CreateObject("ADODB.Stream")
  tstream.Type = 1
  tstream.Mode = 3
  tstream.Open
  stream.Position = s
  stream.CopyTo tstream, size
  tstream.SaveToFile FilePath, 2
  tstream.Close
  Set tstream = Nothing
  If Err <> 0 Then
    errMsg = errMsg & sfn & "上传失败！"
  Else
    AllFile = AllFile & FileName & ","
  End If
  On Error GoTo 0
End Function

Public Function UpDB(connstr, FileName)
   Dim arr, id, tid, sql, affectRecords, conn
   Set conn = MyServer.CreateObject("adodb.connection")
   conn.Open connstr
   affectRecords = 0
   arr = Split(MySession("user"), "|", -1, 1)
   id = arr(0)
   tid = MyRequest.QueryString("tid")
   sql = "update user_editype set vpic='" & FileName & "' where u_id=" & id & " and type_id=" & tid
   conn.Execute sql, affectRecords, ADODB.adExecuteNoRecords + ADODB.adCmdText
   conn.Close
   Set conn = Nothing
   UpDB = affectRecords
End Function
Public Function DelPic(constr)
  Dim arr, fso, rps, tid, id, sql, vpic, affectRecords, FilePath, conn
  Set conn = MyServer.CreateObject("adodb.connection")
  conn.Open constr
  affectRecords = 0
  arr = Split(MySession("user"), "|", -1, 1)
  id = arr(0)
  tid = MyRequest.QueryString("tid")
  Set fso = MyServer.CreateObject("Scripting.FileSystemObject")
  sql = "select vpic from user_editype where type_id=" & tid & " and u_id=" & id & " "
  DelPic = sql
  Set rps = conn.Execute(sql, affectRecords, ADODB.adCmdText)
  If Not rps.EOF Then vpic = rps("vpic")
  rps.Close
  Set rps = Nothing
  If vpic <> "" Then FilePath = MyServer.MapPath(RootPath & vpic)
  On Error Resume Next
  If fso.FileExists(FilePath) Then
     fso.DeleteFile (FilePath)
  End If
  Set fso = Nothing
  '更新数据库
  sql = "update user_editype set vpic=null  where type_id=" & tid & " and u_id=" & id & " "
  If Err = 0 Then conn.Execute sql, affectRecords, ADODB.adExecuteNoRecords + ADODB.adCmdText
  On Error GoTo 0
  conn.Close
  Set conn = Nothing
  DelPic = affectRecords
End Function