View Source Code

SourceFileName = "samples/fileup.asp"

C:\inetpub\wwwroot\aspsample\samples\fileup.asp

<!-- このスクリプトはご自由にご利用頂いて結構ですが、無断転用などを禁止いたします。Copyright K.Nakajima -->
<!-- 下記のuseridの部分をお客様のユーザーIDと置き換えて下さい。-->
<!-- このスクリプトの実行には、「bbs-g.asp」と「fileup.htm」も必要となります。 -->
<%
a = Request.TotalBytes
b = Request.BinaryRead(a)
set obj=server.createobject("basp21")
NAME = obj.Form(b,"name")
MAIL = obj.Form(b,"mail")
TITLE = obj.Form(b,"title")
filename = obj.Form(b,"filename")
MSG = obj.Form(b,"msg")
LINK = obj.Form(b,"link")
'SENAME = obj.Form(b,"sename")
f = obj.FormFileName(b,"file")
fsize = obj.FormFileSize(b,"file")
newf  = Mid(f,InstrRev(f,"\")+1)
extf  = LCase(Mid(newf,Len(newf)-3,4))
'newf = obj.strftime("%Y%m%d%H%M%S")
Select Case extf
  Case ".gif" , ".jpg" , ".mov" , ".txt" , ".wav" , ".htm"
    fok  = 1
    newf = obj.strftime("%Y%m%d%H%M%S") & extf
  Case Else
    fok  = 0
    newf = ""
End Select
If NAME="" Or TITLE = "" Or MSG = "" Then
  Response.Write "<BR><FONT SIZE=6 COLOR=#FF0000>E-Mail,LINK 以外の項目は全て入力して下さい。</FONT><BR><BR>"
Else
  If newf <> "" Then
    l = obj.FormSaveAs(b,"file","c:\InetPub\wwwroot\userid\_exc\file\" & newf)
  End if
  Call Write
  Response.Write "<HTML><HEAD><TITLE>File Upload Test</TITLE><BODY>"
  Response.Write "<H1>Testing</H1><BR>" & name & "さん、アップロードされました<BR>"
  Response.Write "file  = " & newf & "<BR>"
  Response.Write "len   = " & cStr(l) & "<BR>"
  If fok = 0 And extf <> "" Then
    Response.Write "<font color=red>（gif/jpg/mov/wav/txt/htm以外の拡張子のファイルはアップロード出来ません。）</font>"
  End if
  Response.Write "</BODY></HTML>"
End if
%>
<script LANGUAGE="VBScript" RUNAT="Server"> 

Sub Write
 MSG = Replace(MSG, Chr(13), "<BR>")
 MSG = Replace(MSG, Chr(10), "")
 EDate = FormatDateTime(now(), vbShortDate) & " " & FormatDateTime(now(), vbShortTime)

 Set objFile = Server.CreateObject("Scripting.FileSystemObject")
 LogFile = Server.MapPath("_exc\bbslog-g.txt")
 Set InStream = objFile.OpenTextFile(LogFile, 1, False)
 sOldLog = InStream.ReadAll
 iNo = InStream.line
 InStream.Close

 sWriteBuf = "<TABLE CELLPADDING=4 WIDTH=100% BORDER><TR>"
 sWriteBuf = sWriteBuf & "<TD BGCOLOR=#CCFFCC WIDTH=60>#" & Right("0000" & CSTR(iNo), 4) & "</TD>"
 If MAIL = "" Then
   sWriteBuf = sWriteBuf & "<TD BGCOLOR=#CCFFCC>" & NAME & "</TD>"
 Else
   sWriteBuf = sWriteBuf & "<TD BGCOLOR=#CCFFCC><A HREF=" & Chr(34) & "mailto:" & MAIL & Chr(34) & ">" & NAME & "</A></TD>"
 End If
 sWriteBuf = sWriteBuf & "<TD BGCOLOR=#CCFFCC WIDTH=120 ALIGN=CENTER><FONT SIZE=2>" & EDate & "</FONT></TD></TR></TABLE>"
 sWriteBuf = sWriteBuf & "<TABLE CELLPADDING=4 WIDTH=100% BORDER>"
 sWriteBuf = sWriteBuf & "<TR><TD BGCOLOR=#CCCCCC COLSPAN=3>" & TITLE & "</TD></TR>"
 If newf <> "" Then
   If fsize<1024 Then
     fsize0 = cStr(fsize)
   Else
     If fsize<1048576 Then
       fsize0 = cStr(cInt(fsize/1024)) & "K"
     Else
       fsize0 = cStr(cInt(fsize/1048576)) & "M"
     End if
   End if
   sWriteBuf = sWriteBuf & "<BLOCKQUOTE> 画　像：　<A HREF='_exc/file/" & newf & "' TARGET=top><img src='_exc/file/" & newf & "' width=256 height=192 border=0>" & filename & "</A>-(" & fsize0 & "B)</BLOCKQUOTE>"
 End if
 sWriteBuf = sWriteBuf & "<TR><TD BGCOLOR=WHITE COLSPAN=3>" & MSG
 If LINK = "http://" Then
   sWriteBuf = sWriteBuf & "</TD></TR>"
 Else
   sWriteBuf = sWriteBuf & "<BR><A HREF=" & Chr(34) & LINK & Chr(34) & "target=" & Chr(34) & "_blank" & Chr(34) & ">" & LINK & "</A></TD></TR>"
 End If
 sWriteBuf = sWriteBuf & "</TABLE><BR>"

 Set fs = CreateObject("Scripting.FileSystemObject")
 Set OutStream = fs.CreateTextFile("c:\InetPub\wwwroot\userid\_exc\bbslog-g.txt", True)
 OutStream.WriteLine sWriteBuf
 OutStream.Write sOldLog
 OutStream.Close

End Sub
</Script>