kalo saya pernah nyoba kira2 2 thn yang lalu
kayak begini....
kalo misalnya secriptnya sama mohon maaf
ini saya ambil dari sebuah artikel di asptoday.com
dengan modifikasi sesuai keperluan saya waktu itu....
cobas di lihat dulu apa bernar atau tidak sekrip saya ini....
maka mas
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
Const IncludeType = 2
'Limit of upload size
Dim UploadSizeLimit
'********************************** GetUpload
**********************************
'This function reads all form fields from binary input and returns it as a
dictionary object.
'The dictionary object containing form fields. Each form field is
represented by six values :
'.Name name of the form field (<Input Name="..." Type="File,...">)
'.ContentDisposition = Content-Disposition of the form field
'.FileName = Source file name for <input type=file>
'.ContentType = Content-Type for <input type=file>
'.Value = Binary value of the source field.
'.Length = Len of the binary data field
Function GetUpload()
Dim Result
Set Result = Nothing
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method
must be "POST"
Dim CT, PosB, Boundary, Length, PosE
CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type
header
If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type header
must be "multipart/form-data"
'This is upload request.
'Get the boundary and length from Content-Type header
PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary
Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get
Content-Length header
If "" & UploadSizeLimit <> "" Then
UploadSizeLimit = CLng(UploadSizeLimit)
If Length > UploadSizeLimit Then
Request.BinaryRead (Length)
Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length, 0)
& "B exceeds limit of " & FormatNumber(UploadSizeLimit, 0) & "B"
Exit Function
End If
End If
If Length > 0 And Boundary <> "" Then 'Are there required informations
about upload ?
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(Length) 'Reads binary data from client
'Retrieves the upload fields from binary data
Set Result = SeparateFields(Binary, Boundary)
Binary = Empty 'Clear variables
Else
Err.Raise 10, "GetUpload", "Zero length request ."
End If
Else
Err.Raise 11, "GetUpload", "No file sent."
End If
Else
Err.Raise 1, "GetUpload", "Bad request method."
End If
Set GetUpload = Result
End Function
'********************************** SeparateFields
**********************************
'This function retrieves the upload fields from binary data and retuns the
fields as array
'Binary is safearray ( VT_UI1 | VT_ARRAY ) of all document raw binary data
from input.
Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Dim Fields
Boundary = StringToBinary(Boundary)
PosOpenBoundary = InStrB(Binary, Boundary)
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary,
Boundary, 0)
Set Fields = CreateObject("Scripting.Dictionary")
Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not
isLastBoundary)
'Header and file/source field data
Dim HeaderContent, FieldContent, bFieldContent
'Header fields
Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Helping variables
Dim Field, TwoCharsAfterEndBoundary
'Get end of header
PosEndOfHeader = InStrB(PosOpenBoundary + Len(Boundary), Binary,
StringToBinary(vbCrLf + vbCrLf))
'Separates field header
HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2,
PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
'Separates field content
bFieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary -
(PosEndOfHeader + 4) - 2)
'Separates header fields from header
GetHeadFields BinaryToString(HeaderContent), Content_Disposition,
FormFieldName, SourceFileName, Content_Type
'Create one field and assign parameters
Set Field = CreateUploadField()'See the JS function bellow
Set FieldContent = CreateBinaryData()'See the JS function bellow
FieldContent.ByteArray = bFieldContent
FieldContent.Length = LenB(bFieldContent)
Field.Name = FormFieldName
Field.ContentDisposition = Content_Disposition
Field.FilePath = SourceFileName
Field.FileName = GetFileName(SourceFileName)
Field.ContentType = Content_Type
Field.Length = FieldContent.Length
Set Field.Value = FieldContent
Fields.Add FormFieldName, Field
'Is this last boundary ?
TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary
+ LenB(Boundary), 2))
isLastBoundary = TwoCharsAfterEndBoundary = "--"
If Not isLastBoundary Then 'This is not last boundary - go to next form
field.
PosOpenBoundary = PosCloseBoundary
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary,
Boundary)
End If
Loop
Set SeparateFields = Fields
End Function
'********************************** Utilities
**********************************
'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName,
Content_Type)
Content_Disposition = LTrim(SeparateField(Head, "content-disposition:",
";"))
Name = (SeparateField(Head, "name=", ";")) 'ltrim
If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
FileName = (SeparateField(Head, "filename=", ";")) 'ltrim
If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2,
Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function
'Separates one field between sStart and sEnd
Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function
'Separetes file name from the full path of file
Function GetFileName(FullPath)
Dim Pos, PosF
PosF = 0
For Pos = Len(FullPath) To 1 Step -1
Select Case Mid(FullPath, Pos, 1)
Case "/", "\": PosF = Pos + 1: Pos = 0
End Select
Next
If PosF = 0 Then PosF = 1
GetFileName = Mid(FullPath, PosF)
End Function
'Simulate ByteArray class by JS/VBS
Function BinaryToString(Binary)
dim cl1, cl2, cl3, pl1, pl2, pl3
Dim L', nullchar
cl1 = 1
cl2 = 1
cl3 = 1
L = LenB(Binary)
Do While cl1<=L
pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1)))
cl1 = cl1 + 1
cl3 = cl3 + 1
if cl3>300 then
pl2 = pl2 & pl3
pl3 = ""
cl3 = 1
cl2 = cl2 + 1
if cl2>200 then
pl1 = pl1 & pl2
pl2 = ""
cl2 = 1
End If
End If
Loop
BinaryToString = pl1 & pl2 & pl3
End Function
Function BinaryToStringold(Binary)
Dim I, S
For I = 1 To LenB(Binary)
S = S & Chr(AscB(MidB(Binary, I, 1)))
Next
BinaryToString = S
End Function
Function StringToBinary(String)
Dim I, B
For I=1 to len(String)
B = B & ChrB(Asc(Mid(String,I,1)))
Next
StringToBinary = B
End Function
'The function simulates save binary data using conversion to string and
filesystemobject
Function vbsSaveAs(FileName, ByteArray)
Dim FS, TextStream
Set FS = CreateObject("Scripting.FileSystemObject")
Set TextStream = FS.CreateTextFile(FileName)
'And this is the problem why only short files - BinaryToString uses
byte-to-char VBS conversion. It takes a lot of computer time.
TextStream.Write BinaryToString(ByteArray) ' BinaryToString is in
upload.inc.
TextStream.Close
End Function
'Simulate ByteArray class by JS/VBS - end
</SCRIPT>
<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
// The function creates Field object. I'm sorry to use JScript, but VBScript
can't create custom objects till version 5.0
function CreateUploadField(){ return new uf_Init() }
function uf_Init(){
this.Name = null
this.ContentDisposition = null
this.FileName = null
this.FilePath = null
this.ContentType = null
this.Value = null
this.Length = null
}
// Simulate ByteArray class by JS/VBS
function CreateBinaryData(){ return new bin_Init() }
function bin_Init(){
this.ByteArray = null
this.Length = null
this.String = jsBinaryToString
this.SaveAs = jsSaveAs
}
function jsBinaryToString(){
return BinaryToString(this.ByteArray)
};
function jsSaveAs(FileName){
return vbsSaveAs(FileName, this.ByteArray)
}
// Simulate ByteArray class by JS/VBS - end
</SCRIPT>
Boenboen
Staff Accounting
----- Original Message -----
From: Hendikin <[EMAIL PROTECTED]>
To: <[EMAIL PROTECTED]>
Sent: Tuesday, February 13, 2001 1:09 AM
Subject: RE: [MasterWeb] teknik upload
> ok deh masa segitu aja marah :)
> jangan gitu donk
> yang udah ogut kasih yang lengkap
> mo upload untuk upload file
>
> tapi kalo kepanjangan jangan protes yach
>
> kasih nama upload.asp
> <FORM METHOD="Post" ENCTYPE="multipart/form-data"
> ACTION="outputFile.asp">
> <input type="hidden" value="prod5.gif" name="namafile">
> <input type="file" name="blob" size="20"><input type="submit" value="Up
> Load" name="B2"></font></p>
> </form>
>
> kalo yang ini kasih nama outputfile.asp
>
> <%
>
> Response.Expires=0
> Response.Buffer = TRUE
> Response.Clear
> 'Response.BinaryWrite(Request.BinaryRead(Request.TotalBytes))
> byteCount = Request.TotalBytes
> 'Response.BinaryWrite(Request.BinaryRead(varByteCount))
>
> RequestBin = Request.BinaryRead(byteCount)
> Dim UploadRequest
> Set UploadRequest = CreateObject("Scripting.Dictionary")
>
> BuildUploadRequest RequestBin
>
> namafile = UploadRequest.Item("namafile").Item("Value")
>
> contentType = UploadRequest.Item("blob").Item("ContentType")
> filepathname = UploadRequest.Item("blob").Item("FileName")
> filename =
Right(filepathname,Len(filepathname)-InstrRev(filepathname,"\"))
> value = UploadRequest.Item("blob").Item("Value")
>
> 'Create FileSytemObject Component
> Set ScriptObject = Server.CreateObject("Scripting.FileSystemObject")
>
> 'Create and Write to a File
> pathEnd = Len(Server.mappath(Request.ServerVariables("PATH_INFO")))-14
> Set MyFile =
>
ScriptObject.CreateTextFile(Left(Server.mappath(Request.ServerVariables("PAT
> H_INFO")),pathEnd)&"\" & Session("Userid") &"\"& namafile)
>
> For i = 1 to LenB(value)
> MyFile.Write chr(AscB(MidB(value,i,1)))
> Next
>
> MyFile.Close
> %>
> <!--#include file="uploadprocedure.asp"-->
> <script language="vbscript">
> msgbox ("Upload Complete")
> history.back(0)
> </script>
>
>
> kalo yang satu ini kasih nama file uploadprocedure.asp
>
> <%
>
>
>
> Sub BuildUploadRequest(RequestBin)
> 'Get the boundary
> PosBeg = 1
> PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
> boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
> boundaryPos = InstrB(1,RequestBin,boundary)
> 'Get all data inside the boundaries
> Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--")))
> 'Members variable of objects are put in a dictionary object
> Dim UploadControl
> Set UploadControl = CreateObject("Scripting.Dictionary")
> 'Get an object name
> Pos = InstrB(BoundaryPos,RequestBin,getByteString("Content-Disposition"))
> Pos = InstrB(Pos,RequestBin,getByteString("name="))
> PosBeg = Pos+6
> PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
> Name = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
> PosFile = InstrB(BoundaryPos,RequestBin,getByteString("filename="))
> PosBound = InstrB(PosEnd,RequestBin,boundary)
> 'Test if object is of file type
> If PosFile<>0 AND (PosFile<PosBound) Then
> 'Get Filename, content-type and content of file
> PosBeg = PosFile + 10
> PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))
> FileName = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
> 'Add filename to dictionary object
> UploadControl.Add "FileName", FileName
> Pos = InstrB(PosEnd,RequestBin,getByteString("Content-Type:"))
> PosBeg = Pos+14
> PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
> 'Add content-type to dictionary object
> ContentType = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
> UploadControl.Add "ContentType",ContentType
> 'Get content of object
> PosBeg = PosEnd+4
> PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
> Value = MidB(RequestBin,PosBeg,PosEnd-PosBeg)
> Else
> 'Get content of object
> Pos = InstrB(Pos,RequestBin,getByteString(chr(13)))
> PosBeg = Pos+4
> PosEnd = InstrB(PosBeg,RequestBin,boundary)-2
> Value = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))
> End If
> 'Add content to dictionary object
> UploadControl.Add "Value" , Value
> 'Add dictionary object to main dictionary
> UploadRequest.Add name, UploadControl
> 'Loop to next object
> BoundaryPos=InstrB(BoundaryPos+LenB(boundary),RequestBin,boundary)
> Loop
>
> End Sub
>
> 'String to byte string conversion
> Function getByteString(StringStr)
> For i = 1 to Len(StringStr)
> char = Mid(StringStr,i,1)
> getByteString = getByteString & chrB(AscB(char))
> Next
> End Function
>
> 'Byte string to string conversion
> Function getString(StringBin)
> getString =""
> For intCount = 1 to LenB(StringBin)
> getString = getString & chr(AscB(MidB(StringBin,intCount,1)))
> Next
> End Function
> %>
>
>
> semoga membantu semuanya
> :)
> Hendikin
> ASP Programmer / WEB Developer
> HP : 0816-1369935
> Ph : 021-3142356
>
>
>
>
> Belanja Komputer & PC Asesoris Diskon 40% hanya di www.fastncheap.com
> Tempat Asik Hosting Indonesia www.neocyber.net
> Dapatkan Paket-Paket Website www.dlanet.com
>
> -------[ Master Web Indonesia - www.master.web.id ] -------
> Berlangganan : [EMAIL PROTECTED]
> Stop Berlangganan : [EMAIL PROTECTED]
> Arsip MailingList : [EMAIL PROTECTED]
> -----------------------------------------------------------
>
>
Belanja Komputer & PC Asesoris Diskon 40% hanya di www.fastncheap.com
Tempat Asik Hosting Indonesia www.neocyber.net
Dapatkan Paket-Paket Website www.dlanet.com
-------[ Master Web Indonesia - www.master.web.id ] -------
Berlangganan : [EMAIL PROTECTED]
Stop Berlangganan : [EMAIL PROTECTED]
Arsip MailingList : [EMAIL PROTECTED]
-----------------------------------------------------------
