📄 upfile_class_aspx_ftbbs_class.vb
字号:
'upfile_class_aspx
' ***************************************************
' * 本程序由AspToAspX风火轮0.99转换生成 *
' * http://Www.AspToAspX.Cn *
' * Q Q : 139227536 *
' * QQ群: 17152722 *
' * MSN : gzliangjianhua@hotmail.com *
' * EMail AspToDll@vip.163.com *
' ***************************************************
Imports Microsoft.VisualBasic
Imports System.Web
Imports System.Math
Imports System.Web.SessionState
Public Class Ftbbs_Class
Public AspToAspX_Host_Class_Object As Object
Public Form
Public File
Public AllowExt_
Public NoAllowExt_
Private oUpFileStream
Private isErr_
Private ErrMessage_
Private isGetData_
Sub New(ByRef host As Object)
On Error GoTo _AspToAspX_Err
AspToAspX_Host_Class_Object = host
isErr_ = 0 '36
NoAllowExt = "" '37
NoAllowExt = LCase ( NoAllowExt ) '38
AllowExt = "" '39
AllowExt = LCase ( AllowExt ) '40
isGetData_ = false '41
Exit Sub
_AspToAspX_Err:
AspToAspX_WriteLog (" New:" & Err.Description)
Resume Next
End Sub
Private Sub Class_Terminate
On Error GoTo _AspToAspX_Err
On Error Resume Next '45
Form.RemoveAll ( ) '47
Form = Nothing '48
File.RemoveAll ( ) '49
File = Nothing '50
oUpFileStream.Close ( ) '51
oUpFileStream = Nothing '52
Exit Sub
_AspToAspX_Err:
AspToAspX_WriteLog (" Class_Terminate:" & Err.Description)
Resume Next
End Sub
Public Sub GetData(ByRef MaxSize )
On Error GoTo _AspToAspX_Err
Dim RequestBinDate
Dim sSpace
Dim bCrLf
Dim sInfo
Dim iInfoStart
Dim iInfoEnd
Dim tStream
Dim iStart
Dim oFileInfo
Dim sFormValue
Dim sFileName
Dim iFindStart
Dim iFindEnd
Dim iFormStart
Dim iFormEnd
Dim sFormName
On Error Resume Next '57
If AspToAspX_CheckDBNull ( isGetData_ ) = false Then '58
If AspToAspX_CheckDBNull ( Request.TotalBytes ) < 1 Then '64
isErr_ = 1 '65
ErrMessage_ = "没有数据上传" '66
Exit Sub '67
End If '68
If AspToAspX_CheckDBNull ( MaxSize ) > 0 Then '69
If AspToAspX_CheckDBNull ( Request.TotalBytes ) > MaxSize Then '70
isErr_ = 2 '71
ErrMessage_ = "上传的数据超出限制大小" '72
Exit Sub '73
End If '74
End If '75
Form = New Scripting.Dictionary ( ) '76
Form.CompareMode = 1 '77
File = New Scripting.Dictionary ( ) '78
File.CompareMode = 1 '79
tStream = New ADODB.Stream ( ) '80
oUpFileStream = New ADODB.Stream ( ) '81
oUpFileStream.Type = 1 '82
oUpFileStream.Mode = 3 '83
oUpFileStream.Open ( ) '84
oUpFileStream.Write ( Request.BinaryRead ( Request.TotalBytes ) ) '85
oUpFileStream.Position = 0 '86
RequestBinDate = oUpFileStream.Read '87
iFormEnd = oUpFileStream.Size '88
bCrLf = Chr ( 13 ) & Chr ( 10 ) '89
sSpace = AspToAspX_MidB ( RequestBinDate , 1 , AspToAspX_InStrB ( 1 , RequestBinDate , bCrLf ) - 1 ) '91
iStart = AspToAspX_Len ( sSpace ) '92
iFormStart = iStart + 2 '93
Do '95
iInfoEnd = AspToAspX_InStrB ( iFormStart , RequestBinDate , bCrLf & bCrLf ) + 3 '96
tStream.Type = 1 '97
tStream.Mode = 3 '98
tStream.Open ( ) '99
oUpFileStream.Position = iFormStart '100
oUpFileStream.CopyTo ( tStream , iInfoEnd - iFormStart ) '101
tStream.Position = 0 '102
tStream.Type = 2 '103
tStream.CharSet = "utf-8" '104
sInfo = tStream.ReadText '105
iFormStart = AspToAspX_InStrB ( iInfoEnd , RequestBinDate , sSpace ) - 1 '107
iFindStart = InStr ( 22 , sInfo , "name=""" , 1 ) + 6 '108
iFindEnd = InStr ( iFindStart , sInfo , """" , 1 ) '109
sFormName = Mid ( sinfo , iFindStart , iFindEnd - iFindStart ) '110
If AspToAspX_CheckDBNull ( InStr ( 45 , sInfo , "filename=""" , 1 ) ) > 0 Then '112
oFileInfo = New clsFileInfo ( AspToAspX_Host_Class_Object ) '113
iFindStart = InStr ( iFindEnd , sInfo , "filename=""" , 1 ) + 10 '115
iFindEnd = InStr ( iFindStart , sInfo , """" & vbCrLf , 1 ) '116
sFileName = Mid ( sinfo , iFindStart , iFindEnd - iFindStart ) '117
oFileInfo.FileName = GetFileName ( sFileName ) '118
oFileInfo.FilePath = GetFilePath ( sFileName ) '119
oFileInfo.FileExt = GetFileExt ( sFileName ) '120
iFindStart = InStr ( iFindEnd , sInfo , "Content-Type: " , 1 ) + 14 '121
iFindEnd = InStr ( iFindStart , sInfo , vbCr ) '122
oFileInfo.FileMIME = Mid ( sinfo , iFindStart , iFindEnd - iFindStart ) '123
oFileInfo.FileStart = iInfoEnd '124
oFileInfo.FileSize = iFormStart - iInfoEnd - 2 '125
oFileInfo.FormName = sFormName '126
file.add ( sFormName , oFileInfo ) '127
Else '128
tStream.Close ( ) '130
tStream.Type = 1 '131
tStream.Mode = 3 '132
tStream.Open ( ) '133
oUpFileStream.Position = iInfoEnd '134
oUpFileStream.CopyTo ( tStream , iFormStart - iInfoEnd - 2 ) '135
tStream.Position = 0 '136
tStream.Type = 2 '137
tStream.CharSet = "utf-8" '138
sFormValue = tStream.ReadText '139
If Form.Exists ( sFormName ) Then '140
Form ( sFormName ) = Form ( sFormName ) & ", " & sFormValue '141
Else '142
Form.Add ( sFormName , sFormValue ) '143
End If '144
End If '145
tStream.Close ( ) '146
iFormStart = iFormStart + iStart + 2 '147
Loop Until ( iFormStart + 2 ) > = iFormEnd '149
RequestBinDate = "" '150
tStream = Nothing '151
isGetData_ = true '152
End If '153
Exit Sub
_AspToAspX_Err:
AspToAspX_WriteLog (" GetData:" & Err.Description)
Resume Next
End Sub
Public Function SaveToFile(ByRef Item,ByRef Path )
On Error GoTo _AspToAspX_Err
SaveToFile = SaveToFileEx ( Item , Path , True ) '157
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" SaveToFile:" & Err.Description)
Resume Next
End Function
Private Function SaveToFileEx(ByRef Item,ByRef Path,ByRef Over )
On Error GoTo _AspToAspX_Err
Dim oFileStream
Dim tmpPath
Dim ftmod
On Error Resume Next '161
isErr_ = 0 '165
oFileStream = New ADODB.Stream ( ) '166
oFileStream.Type = 1 '167
oFileStream.Mode = 3 '168
oFileStream.Open ( ) '169
oUpFileStream.Position = File ( Item ).FileStart '170
oUpFileStream.CopyTo ( oFileStream , File ( Item ).FileSize ) '171
AspToAspX_Host_Class_Object.ftbbs_char = AspToAspX_Host_Class_Object.Ftbbs_Counter ( Path ) '173
If AspToAspX_CheckDBNull ( AspToAspX_Host_Class_Object.ftbbs_char ) > 1 Then '174
tmpPath = AspToAspX_Split ( Path , "." ) '175
tmpPath = AspToAspX_Split ( Path , "." ) ( UBound ( tmpPath ) ) '176
tmpPath = replace ( Path , "." & tmpPath , "" ) & "." & tmpPath '177
Else '178
AspToAspX_Host_Class_Object.ftbbs_tmpPath = AspToAspX_Split ( Path , "." ) '179
tmpPath = AspToAspX_Host_Class_Object.ftbbs_tmpPath ( 0 ) & "." & AspToAspX_Host_Class_Object.ftbbs_tmpPath ( UBound ( AspToAspX_Host_Class_Object.ftbbs_tmpPath ) ) '180
End If '181
If Over Then '182
If isAllowExt ( GetFileExt ( tmpPath ) ) Then '183
oFileStream.SaveToFile ( tmpPath , 2 ) '184
Else '185
isErr_ = 3 '186
ErrMessage_ = "你上传的文件类型不允许 <a href=" & AspToAspX_GetRequestServerVariables ( "Http_REFERER" ) & ">重新上传</a>" '187
End If '188
Else '189
Path = GetFilePath ( Path ) '190
isErr_ = 3 '191
ErrMessage_ = "该后缀名的文件不允许上传!" '192
End If '193
oFileStream.Close ( ) '194
oFileStream = Nothing '195
If AspToAspX_CheckDBNull ( isErr_ ) = 3 Then
SaveToFileEx = ""
Else
SaveToFileEx = GetFileName ( tmpPath )
End If
'196
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" SaveToFileEx:" & Err.Description)
Resume Next
End Function
Public Function FileData(ByRef Item )
On Error GoTo _AspToAspX_Err
isErr_ = 0 '200
If isAllowExt ( File ( Item ).FileExt ) Then '201
oUpFileStream.Position = File ( Item ).FileStart '202
FileData = oUpFileStream.Read ( File ( Item ).FileSize ) '203
Else '204
isErr_ = 3 '205
ErrMessage_ = "该后缀名的文件不允许上传!" '206
FileData = "" '207
End If '208
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" FileData:" & Err.Description)
Resume Next
End Function
Public Function GetFilePath(ByRef FullPath )
On Error GoTo _AspToAspX_Err
If AspToAspX_CheckDBNull ( FullPath ) < > EmptyString.Value Then '212
GetFilePath = Left ( FullPath , InStrRev ( FullPath , "\" ) ) '213
Else '214
GetFilePath = "" '215
End If '216
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" GetFilePath:" & Err.Description)
Resume Next
End Function
Public Function GetFileName(ByRef FullPath )
On Error GoTo _AspToAspX_Err
If AspToAspX_CheckDBNull ( FullPath ) < > EmptyString.Value Then '220
GetFileName = mid ( FullPath , InStrRev ( FullPath , "\" ) + 1 ) '221
Else '222
GetFileName = "" '223
End If '224
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" GetFileName:" & Err.Description)
Resume Next
End Function
Public Function GetFileExt(ByRef FullPath )
On Error GoTo _AspToAspX_Err
If AspToAspX_CheckDBNull ( FullPath ) < > EmptyString.Value Then '228
GetFileExt = LCase ( Mid ( FullPath , InStrRev ( FullPath , "." ) + 1 ) ) '229
Else '230
GetFileExt = "" '231
End If '232
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" GetFileExt:" & Err.Description)
Resume Next
End Function
Public Function isAllowExt(ByRef Ext )
On Error GoTo _AspToAspX_Err
If AspToAspX_CheckDBNull ( NoAllowExt ) = EmptyString.Value Then '235
isAllowExt = AspToAspX_ConvertBool ( InStr ( 1 , "|" & AllowExt & "|" , LCase ( "|" & Ext & "|" ) ) ) '236
Else '237
isAllowExt = Not AspToAspX_ConvertBool ( InStr ( 1 , "|" & NoAllowExt & "|" , LCase ( "|" & Ext & "|" ) ) ) '238
End If '239
Exit Function
_AspToAspX_Err:
AspToAspX_WriteLog (" isAllowExt:" & Err.Description)
Resume Next
End Function
ReadOnly Property Version
Get
Version = "飞天论坛文件上传类V1.0" '14
End Get
End Property
ReadOnly Property isErr
Get
isErr = isErr_
End Get
End Property
ReadOnly Property ErrMessage
Get
ErrMessage = ErrMessage_
End Get
End Property
Property AllowExt
Get
AllowExt = AllowExt_
End Get
Set( Value )
AllowExt_ = LCase ( Value ) '26
End Set
End Property
Property NoAllowExt
Get
NoAllowExt = NoAllowExt_
End Get
Set( Value )
NoAllowExt_ = LCase ( Value ) '32
End Set
End Property
End Class
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -