<% DvBoke.Stats = "上传操作" DvBoke.Head(0) Dim m m = Request.QueryString("mode") Select Case Request.QueryString("mode") Case "UploadForm" : UploadForm() Case "SaveUpload" : SaveUpload() End Select Dvbbs.PageEnd() Sub UploadForm() Dim PageHtml DvBoke.LoadPage("topic.xslt") PageHtml = DvBoke.Page_Strings(26).text PageHtml = Replace(PageHtml,"{$upset}",5) PageHtml = Replace(PageHtml,"{$bokename}",Dvboke.BokeName) Response.Write PageHtml End Sub Sub SaveUpload() Dim MaxSize Server.ScriptTimeOut=999999'要是你的论坛支持上传的文件比较大,就必须设置。 '----------------------------------------------------------------------------- '提交验证 '----------------------------------------------------------------------------- If Not Dvbbs.ChkPost Then Response.End End If If Dvboke.Userid=0 Then Response.write "你还未登陆!" Response.End End If If Dvboke.System_UpSetting(0)="1" Then If Cint(Dvbbs.GroupSetting(7))=0 then Response.write "您没有在本论坛上传文件的权限!" Response.End End If Else If Dvboke.System_UpSetting(1)="0" Then Response.write "您没有在本博客上传文件的权限!" Response.End End If End If MaxSize = Int(Dvboke.System_UpSetting(1)) If MaxSize=0 Then MaxSize = Int(Dvbbs.GroupSetting(44)) End If If Dvboke.BokeNode.getAttribute("spacesize")=0 Then Response.write "当前博客允许的上传空间已满,请与管理员联系。" Response.End ElseIf Dvboke.BokeNode.getAttribute("spacesize")>0 Then If Dvboke.BokeNode.getAttribute("spacesize") <% Dim Upload,FormName,File,F_FileName,F_Viewname '======================================================================== Set Upload = New UpFile_Cls Upload.UploadType = Cint(Dvboke.System_UpSetting(2)) '设置上传组件类型 Upload.UploadPath = FilePath '设置上传路径 Upload.InceptFileType = Replace(DvBoke.System_Setting(16),"|",",") '设置上传文件限制 Upload.MaxSize = MaxSize '单位 KB Upload.InceptMaxFile = 5 '每次上传文件个数上限 'Upload.ChkSessionName = "UploadCode" '防止重复提交,SESSION名与提交的表单要一致。 '预览图片设置 Upload.PreviewType = Cint(Dvboke.System_UpSetting(3)) '设置预览图片组件类型 Upload.PreviewImageWidth = Dvboke.System_UpSetting(14) '设置预览图片宽度 Upload.PreviewImageHeight = Dvboke.System_UpSetting(15) '设置预览图片高度 Upload.DrawImageWidth = Dvboke.System_UpSetting(11) '设置水印图片或文字区域宽度 Upload.DrawImageHeight = Dvboke.System_UpSetting(12) '设置水印图片或文字区域高度 Upload.DrawGraph = Dvboke.System_UpSetting(10) '设置水印透明度 Upload.DrawFontColor = Dvboke.System_UpSetting(6) '设置水印文字颜色 Upload.DrawFontFamily = Dvboke.System_UpSetting(7) '设置水印文字字体格式 Upload.DrawFontSize = Dvboke.System_UpSetting(5) '设置水印文字字体大小 Upload.DrawFontBold = Dvboke.System_UpSetting(8) '设置水印文字是否粗体 Upload.DrawInfo = DrawInfo '设置水印文字信息或图片信息 Upload.DrawType = Dvboke.System_UpSetting(17) '0=不加载水印 ,1=加载水印文字,2=加载水印图片 Upload.DrawXYType = Dvboke.System_UpSetting(13) '"0" =左上,"1"=左下,"2"=居中,"3"=右上,"4"=右下 Upload.DrawSizeType = Dvboke.System_UpSetting(16) '"0"=固定缩小,"1"=等比例缩小 If Dvboke.System_UpSetting(18)<>"" or Dvboke.System_UpSetting(18)<>"0" Then Upload.TransitionColor = Dvboke.System_UpSetting(18) '透明度颜色设置 End If '执行上传 Upload.SaveUpFile If Upload.ErrCodes<>0 Then Response.write "错误:"& Upload.Description & "[ 重新上传 ]" Exit Sub End If If Upload.Count > 0 Then For Each FormName In Upload.UploadFiles Set File = Upload.UploadFiles(FormName) F_FileName = FilePath & File.FileName 'Response.Write File.sFileName 'REsponse.End '创建预览及水印图片 If Upload.PreviewType<>999 and File.FileType=1 then F_Viewname = Previewpath & "pre" & Replace(File.FileName,File.FileExt,"") & "jpg" '创建预览图片:Call CreateView(原始文件的路径,预览文件名及路径,原文件后缀) Upload.CreateView F_FileName,F_Viewname,File.FileExt End If UploadSave F_FileName,ChildFilePath&File.FileName,File.sFileName,File.FileExt,F_Viewname,File.FileSize,File.FileType AllFileName = AllFileName & "
" & Dvbbs.Get_ScriptNameUrl() & DvBoke.System_UpSetting(19) & ChildFilePath&File.FileName Set File = Nothing Next Else Response.write "请正确选择要上传的文件。[ 重新上传 ]" Exit Sub End If Call Suc_upload(Upload.Count,Upload.CountSize,AllFileName) Set Upload = Nothing End Sub Sub Suc_upload(UpCount,upCountSize,AllFileName) Dim SucMsg Dim RemainSize upCountSize = Formatnumber((upCountSize/1024)/1024,2) IF Dvboke.BokeNode.getAttribute("spacesize")<>-1 Then RemainSize = cCur(Dvboke.BokeNode.getAttribute("spacesize")) - upCountSize If RemainSize<0 Then RemainSize = 0 End If Else RemainSize = -1 End If SucMsg = UpCount & "个附件上传成功,共"&upCountSize&"MB ;" If RemainSize = 0 Then SucMsg = SucMsg & "[ 当前博客的空间已满,请与管理员联系。]" Else SucMsg = SucMsg & "[ 继续上传 ]" End If Dvboke.Execute("UPDATE [Dv_Boke_User] SET SpaceSize = '" & RemainSize &"' WHERE UserID = " & DvBoke.BokeUserID) Dim PageHtml DvBoke.LoadPage("topic.xslt") PageHtml = DvBoke.Page_Strings(27).text If m="1" Then SucMsg = SucMsg & "
文件地址:" & AllFileName PageHtml = Replace(PageHtml,"{$SucMsg}",SucMsg) Response.Write PageHtml End Sub '保存上传数据并返回附件ID Sub UploadSave(FileName,ChildFileName,sFileName,FileExt,ViewName,FileSize,F_Type) '所有字段 ID,UserID,UserName,CatID,sType,TopicID,PostID,IsTopic,Title,FileName,FileType,FileSize,FileNote,DownNum,ViewNum,DateAndTime,PreviewImage '字段排序 ID=0 ,UserID=1 ,UserName=2 ,CatID=3 ,sType=4 ,TopicID=5 ,PostID=6 ,IsTopic=7 ,Title=8 ,FileName=9 ,FileType=10 ,FileSize=11 ,FileNote=12 ,DownNum=13 ,ViewNum=14 ,DateAndTime=15 ,PreviewImage=16 'CatID,sType,TopicID,PostID,IsTopic,Title,FileNote,IsLock Dim ShwoFileName ShwoFileName = Dvbbs.Checkstr(Replace(FileName,CheckFolder,"UploadFile/")) ChildFileName = Dvbbs.Checkstr(ChildFileName) DvBoke.Execute("Insert into Dv_Boke_Upfile (BokeUserID,UserID,UserName,FileName,sFileName,FileType,FileSize,PreviewImage,IsLock,IsTopic) values ("& DvBoke.BokeUserID &","& DvBoke.UserID &",'"& DvBoke.BokeUserName &"','"& ChildFileName &"','"& Dvbbs.Checkstr(sFileName) &"',"& F_Type &","& FileSize &",'"& Dvbbs.Checkstr(ViewName) &"',4,-1)") Dim Rs,UpFileID,DownloadID Set Rs=DvBoke.Execute("Select top 1 ID From Dv_Boke_Upfile order by ID desc") DownloadID=rs(0) UpFileID = DownloadID & "," Rs.Close Set Rs=nothing '0=其它,1=图片,2=FLASH,3=音乐,4=电影 If F_Type=1 or F_Type=2 then Response.write "" Else Response.write "" End If Response.write "" End Sub '读取上传目录 Function CheckFolder() If DvBoke.System_UpSetting(19)="" Or DvBoke.System_UpSetting(19)="0" Then DvBoke.System_UpSetting(19)="Boke/UploadFile/" CheckFolder = Replace(Replace(DvBoke.System_UpSetting(19),Chr(0),""),".","") '在目录后加(/) If Right(CheckFolder,1)<>"/" Then CheckFolder=CheckFolder&"/" End Function '按月份自动明名上传文件夹,需要FSO组件支持。 Private Function CreatePath(PathValue) Dim objFSO,Fsofolder,uploadpath '以年月创建上传文件夹,格式:2003-8 uploadpath = year(now) & "-" & month(now) If Right(PathValue,1)<>"/" Then PathValue = PathValue&"/" On Error Resume Next Set objFSO = Dvbbs.iCreateObject("Scripting.FileSystemObject") If objFSO.FolderExists(Server.MapPath(PathValue & DvBoke.BokeUserID ))=False Then objFSO.CreateFolder Server.MapPath(PathValue & DvBoke.BokeUserID) End If If objFSO.FolderExists(Server.MapPath(PathValue & DvBoke.BokeUserID &"/"& uploadpath))=False Then objFSO.CreateFolder Server.MapPath(PathValue & DvBoke.BokeUserID &"/"& uploadpath) End If If Err.Number = 0 Then CreatePath = PathValue & DvBoke.BokeUserID &"/"& uploadpath &"/" Else CreatePath = PathValue End If Set objFSO = Nothing End Function %>