Catatan: Batas-batas Microsoft Support untuk pengembangan Visual Basic 6 telah berubah. Untuk informasi lebih lanjut, silakan lihat http://msdn.microsoft.com/en-us/vstudio/ms788708.
Persyaratan
- Microsoft Windows 2000 dengan Microsoft Internet Information Server 5.0 (IIS) terinstal dan dikonfigurasi
- Jika komputer pengembangan komputer yang berbeda dari server, Anda harus berlaku jaringan atau koneksi Internet ke server yang host halaman ASP.
Setup proyek Microsoft Visual Basic 6 dan kode
- Mulai Visual Basic, dan kemudian memulai sebuah proyek ActiveX DLL yang baru.
- Nama proyek ASPFileUpload.
- Mengubah nama kelas 1 ke File.
- Pada Project menu, klik referensi.
- Di referensi kotak dialog, klik untuk memilih opsi berikut, dan kemudian klik OK:
- Visual Basic untuk aplikasi
- Benda-benda runtime Visual Basic dan prosedur
- Objek Visual Basic dan prosedur
- OLE Automation
- COM + pustaka tipe layanan
- pustaka objek Microsoft Active Server Pages
- Microsoft Scripting Runtime
- Pada Proyek Menu, klik ASPFileUpload properti.
- Dalam Properti proyek kotak dialog, klik untuk memilih Eksekusi tanpa pengawasan dan Disimpan dalam kehabisan memori, lalu klik Oke.
- Paste kode berikut untuk File.cls:
Option Explicit Const ERR_INVALID_FILENAME = vbObjectError + 1000 Const ERR_INVALID_TARGET = vbObjectError + 1001 Const ERR_FILE_EXISTS = vbObjectError + 1002 Const ERR_UPLOAD_CALLED = vbObjectError + 1003 Const VB_ERR_PATH_NOT_FOUND = 76 Private m_objContext As ObjectContext Private m_objRequest As ASPTypeLibrary.Request Private m_strTarget As String Private m_strFileName As String Private m_blnOverWrite As Boolean Private m_blnUploaded As Boolean Private m_lngTotalBytes As Long 'All other form elements go here. Private m_formCol As Scripting.Dictionary Implements ObjectControl Private Function ObjectControl_CanBePooled() As Boolean ObjectControl_CanBePooled = False End Function Private Sub ObjectControl_Activate() Set m_objContext = GetObjectContext() Set m_objRequest = m_objContext("Request") Set m_formCol = New Scripting.Dictionary End Sub Private Sub ObjectControl_Deactivate() Set m_objContext = Nothing Set m_objRequest = Nothing Set m_formCol = Nothing End Sub Public Sub Upload() Const DEFAULT_CHUNK_SIZE = 262144 '256kb Dim bytBeginOfChunk() As Byte Dim bytEndOfChunk() As Byte Dim bytBeginOfName() As Byte Dim bytEndOfName() As Byte Dim bytBeginOfFile() As Byte Dim bytEndOfFile() As Byte Dim bytBeginOfValue() As Byte Dim bytEndOfValue() As Byte Dim bytName() As Byte Dim bytValue() As Byte Dim bytThisChunk() As Byte Dim bytFileName() As Byte Dim lngBeginOfChunk As Long Dim lngEndOfChunk As Long Dim lngBeginOfAttribute As Long Dim lngEndOfAttribute As Long Dim lngBeginOfValue As Long Dim lngEndOfValue As Long Dim blnEndOfData As Boolean Dim lngChunkSize As Long Dim lngBytesLeft As Long Dim lngFileNum As Long Dim strFileName As String On Error GoTo UploadErr If Uploaded Then Err.Raise ERR_UPLOAD_CALLED, App.Title, "The Upload method has already been called." End If bytBeginOfChunk = StrConv("-----------------------------", vbFromUnicode) bytEndOfChunk = StrConv("-----------------------------", vbFromUnicode) bytBeginOfName = StrConv("name=", vbFromUnicode) & ChrB(34) bytEndOfName = ChrB(34) bytBeginOfFile = StrConv("filename=", vbFromUnicode) & ChrB(34) bytEndOfFile = ChrB(34) bytBeginOfValue = ChrB(13) & ChrB(10) & ChrB(13) & ChrB(10) bytEndOfValue = ChrB(13) & ChrB(10) & StrConv("-----------------------------", vbFromUnicode) 'Initialize the chunk size. If m_objRequest.TotalBytes <= DEFAULT_CHUNK_SIZE Then lngChunkSize = m_objRequest.TotalBytes Else lngChunkSize = DEFAULT_CHUNK_SIZE End If 'Get the chunk from the request object. bytThisChunk = m_objRequest.BinaryRead(CVar(lngChunkSize)) 'Initialize the value. lngBeginOfChunk = 1 'Repeat until the end of the data. Do While Not blnEndOfData 'Begin the chunk. lngBeginOfChunk = InStrB(lngBeginOfChunk, bytThisChunk, bytBeginOfChunk) + UBound(bytBeginOfChunk) 'Get name of the item. lngBeginOfAttribute = InStrB(lngBeginOfChunk, bytThisChunk, bytBeginOfName) + UBound(bytBeginOfName) + 1 lngEndOfAttribute = InStrB(lngBeginOfAttribute, bytThisChunk, bytEndOfName) bytName = MidB(bytThisChunk, lngBeginOfAttribute, lngEndOfAttribute - lngBeginOfAttribute) 'Get the value of the item. lngBeginOfValue = InStrB(lngEndOfAttribute, bytThisChunk, bytBeginOfValue, vbBinaryCompare) + UBound(bytBeginOfValue) + 1 lngEndOfValue = InStrB(lngBeginOfValue, bytThisChunk, bytEndOfValue, vbBinaryCompare) If lngEndOfValue = 0 Then 'The item extends the past current chunk. bytValue = MidB(bytThisChunk, lngBeginOfValue, lngChunkSize) Else 'The item value exists in the current chunk. bytValue = MidB(bytThisChunk, lngBeginOfValue, lngEndOfValue - lngBeginOfValue) End If If UCase(StrConv(bytName, vbUnicode)) = "FILE" Then lngBeginOfAttribute = InStrB(lngBeginOfChunk, bytThisChunk, bytBeginOfFile, vbBinaryCompare) + UBound(bytBeginOfFile) + 1 lngEndOfAttribute = InStrB(lngBeginOfAttribute, bytThisChunk, bytEndOfFile, vbBinaryCompare) bytFileName = MidB(bytThisChunk, lngBeginOfAttribute, lngEndOfAttribute - lngBeginOfAttribute) If UBound(bytFileName) < 0 Or UBound(bytValue) < 0 Then Err.Raise ERR_INVALID_FILENAME, App.Title, "Invalid File Name." End If If Me.Target = "" Then Err.Raise ERR_INVALID_TARGET, App.Title, "Invalid Target." End If 'Use the original file name. If Me.FileName = "" Then 'Trim the path from the file name. While InStrB(1, bytFileName, StrConv("\", vbFromUnicode), vbBinaryCompare) > 0 bytFileName = MidB(bytFileName, InStrB(1, bytFileName, StrConv("\", vbFromUnicode)) + 1) Wend 'Set the property. Me.FileName = StrConv(bytFileName, vbUnicode) 'Convert the byte to Unicode. strFileName = Me.Target & Me.FileName Else strFileName = Me.Target & Me.FileName End If 'Check for overwrite. If Me.OverWrite Then 'This is the hack check. Make sure that wildcard characters cannot be used. If Not InStr(1, strFileName, "*") Then If FileExists(strFileName) Then Kill strFileName End If Else Err.Raise ERR_INVALID_FILENAME, App.Title, "The specified file name appears to be invalid." End If Else If FileExists(strFileName) Then Err.Raise ERR_FILE_EXISTS, App.Title, "The file already exists." End If End If lngFileNum = FreeFile Open strFileName For Binary Access Write As #lngFileNum 'Write the file to the destination directory. Put #lngFileNum, , bytValue 'This chunk is empty. Therefore, get a new chunk. lngBytesLeft = m_objRequest.TotalBytes - lngChunkSize 'Start the chunking machine. Do While lngBytesLeft > 0 'Get a new chunk. bytThisChunk = m_objRequest.BinaryRead(CVar(lngChunkSize)) lngEndOfValue = InStrB(1, bytThisChunk, bytEndOfValue, vbBinaryCompare) If lngEndOfValue > 0 Then 'The item value exists in the current chunk. bytThisChunk = MidB(bytThisChunk, 1, lngEndOfValue - 1) End If 'Append the chunk to the file. Put #lngFileNum, , bytThisChunk lngBytesLeft = lngBytesLeft - lngChunkSize If lngBytesLeft < lngChunkSize Then lngChunkSize = lngBytesLeft End If Loop Close #lngFileNum TotalBytes = FileLen(strFileName) ' Exit Do Else If UCase(StrConv(bytName, vbUnicode)) = "SAVEAS" Then Me.FileName = StrConv(bytValue, vbUnicode) Else 'form field other than file, such as textboxes If UBound(bytValue) > 0 And UBound(bytName) > 0 Then m_formCol.Add StrConv(bytName, vbUnicode), StrConv(bytValue, vbUnicode) Else m_formCol.Add StrConv(bytName, vbUnicode), "" End If End If End If 'Get the next chunk. lngBeginOfChunk = lngEndOfValue If InStrB(lngBeginOfChunk, bytThisChunk, bytBeginOfName, vbBinaryCompare) = 0 Then blnEndOfData = True End If Loop Uploaded = True Exit Sub UploadErr: If Err.Number = VB_ERR_PATH_NOT_FOUND Then Err.Raise ERR_INVALID_TARGET, App.Title, "The Target specified does not exist." Else Err.Raise Err.Number, Err.Source, Err.Description End If End Sub Public Property Get Form() As Collection Set Form = m_formCol End Property Public Property Get FileName() As String FileName = m_strFileName End Property Public Property Let FileName(ByVal strNewValue As String) If Uploaded Then Err.Raise ERR_UPLOAD_CALLED, App.Title, "The Upload method has already been called." Else m_strFileName = strNewValue End If End Property Public Property Get OverWrite() As Boolean OverWrite = m_blnOverWrite End Property Public Property Let OverWrite(ByVal blnNewValue As Boolean) If Uploaded Then Err.Raise ERR_UPLOAD_CALLED, App.Title, "The Upload method has already been called." Else m_blnOverWrite = blnNewValue End If End Property Private Property Get Uploaded() As Boolean Uploaded = m_blnUploaded End Property Private Property Let Uploaded(ByVal blnNewValue As Boolean) m_blnUploaded = blnNewValue End Property Public Property Get Target() As String Target = m_strTarget End Property Public Property Let Target(ByVal NewValue As String) If Uploaded Then Err.Raise ERR_UPLOAD_CALLED, App.Title, "The Upload method has already been called." Else m_strTarget = NewValue End If End Property Private Function FileExists(ByVal FileName As String) As Boolean On Error GoTo FileExistsErr FileLen FileName FileExists = True Exit Function FileExistsErr: If Err.Number = VB_ERR_PATH_NOT_FOUND Then FileExists = False End If End Function Public Property Get TotalBytes() As Long TotalBytes = m_lngTotalBytes End Property Private Property Let TotalBytes(ByVal NewValue As Long) m_lngTotalBytes = NewValue End Property
- Mengkompilasi proyek
ASP kode
- Paste kode berikut ke editor seperti Notepad atau
Microsoft Visual Interdev, dan kemudian menyimpannya sebagaiPostFile.asp:
<%@ Language=VBScript %> <html> <head> </head> <body> <form enctype="multipart/form-data" action="uploadfile.asp" method="post" name="main1"> <input name="file" type="file" size="50"> <INPUT type="text" id=text1 name=text1><INPUT type="text" id=text2 name=text2> <input name="submit" type="submit" value="Upload"> </form> </body> </html>
- Salin kode berikut ke editor seperti Notepad atau
Visual Interdev, dan kemudian menyimpannya sebagai UploadFile.asp:
<%@ Language=VBScript %> <% '////////////////////////////////////////////////////////////////////////////////// '// ASPFileUpload.File API '// '// Properties '// FileName '// - Read/Write '// - The file will be saved with this file name. '// - This property can only be set before calling Upload. '// - If no value is specified, the original file name '// - in the HTTP post will be used. '// '// OverWrite '// - Read/Write '// - This property can only be set before calling Upload. '// - If set to false and if the destination file exists, an error '// - is raised. The default value is False. '// '// Target '// - Read/Write '// - The file will be written to this folder. '// - This property can only be set before calling Upload. '// - There is no default value for this property and it is required. '// '// Form '// - ReadOnly '// - Scripting.Dictionary object '// - Can access a specific item by using aspfileupload.Form("item"). '// - Acts like the asp form collection. '// - Can enumerate all values in a collection with for each. '// - Only filled after the Upload method is called. '// '// Methods '// Upload '// - This method parses the HTTP Post and writes the file. '// '// Other '// - ASPFileUpload requires COM+ '// - Any call to the Request.Form() collection will cause the Upload '// method to fail as the method references the Binary contents of the '// Request object through the Request.BinaryRead method. '// - Also, if you access a variable in the Request collection without '// specifying the subcollection that it belongs to, the Request.Form collection '// may be searched. This causes an error in the Upload method. '// '////////////////////////////////////////////////////////////////////////////////// Dim strMsg 'As String ' On Error Resume Next dim fuFile set fuFile = server.CreateObject("aspFileupload.file") 'Set the destination folder. fuFile.Target = "C:\TEMP\AspFileUpload\" fuFile.Upload If Err.number = 0 Then strMsg = fuFile.FileName & " was uploaded successfully." Else strMsg = "An error occurred when uploading your file: " & Err.Description End If for each o in fuFile.Form Response.Write o & "<BR>" next Response.Write fuFile.Form.item("text1") & " : " & fuFile.Form.item("text2") ' Response.Write Request.Form("test") set fufile = nothing %> <html> <head></head> <body> <%=strMsg%> </body> </html>
Set Up Server
- Membuat folder pada server Web yang akan menerima upload file, sepertiC:\TEMP\AspFileUpload.
- Salin ASPFileUpload.dll file ke server Web, dan kemudian
mendaftar dengan menggunakan perintah berikut pada prompt perintah:regsvr32 PathToDLL\ASPFileUpload.dll
- Menerapkan file permissions (akses tulis) untuk pengguna yang Anda inginkan untuk dapat meng-upload file.
- Klik Mulai, arahkan kePengaturan, lalu klik Kontrol Panel.
- Di Control Panel, klik Administrasi Alat, lalu klik Komponen Layanan untuk membuka Komponen Layanan di konsol manajemen Microsoft (MMC).
- Memperluas Komponen Layanan node,Komputer node, Komputer saya node, danCOM + aplikasi node.
- Klik kanan node, arahkan ke Baru, lalu klikAplikasi.
- Dalam Menginstal atau menciptakan sebuah aplikasi baru kotak dialog, klik Membuat aplikasi kosong, nama aplikasi, pastikan bahwa Anda mengklik untuk memilih Server aplikasi, lalu klik Berikutnya.
- Dalam Mengatur aplikasi identitas dialog kotak, klik Pengguna ini, kemudian ketik mandat untuk akun pengguna yang sesuai. Akun pengguna harus mempunyai akses menulis ke folder yang akan menerima file upload.
- Klik Selesai.
- Memperluas node yang baru Anda buat untuk ini aplikasi.
- Klik kanan anggukan, arahkan ke Baru, dan kemudian klik Komponen.
- Klik Menginstal komponen baru, dan menemukan folder di mana Anda telah disimpan dan terdaftar berkas .dll, klik file, klik Berikutnya, lalu klikSelesai.
- Salin Postfile.asp file dan Uploadfile.asp file untuk folder akar Web Anda. Secara default, map akar Web adalah C:\Inetpub\Wwwroot.
- Mengedit folder target Uploadfile.asp untuk mencerminkan
folder yang Anda buat pada langkah 1. Target folder tugas terletak di
baris kode berikut:
fuFile.Target = "C:\TEMP\AspFileUpload\"
Mengunggah berkas
- Di Web browser, buka halaman Postfile.asp di
URL berikut:http://YourWebServer/Postfile.asp
- Pilih file yang ingin Anda upload, dan kemudian klikMeng-upload.
- Periksa upload folder. File yang Anda upload muncul dalam map ini.
Sumber dari : http://support.microsoft.com/kb/299692/id-id
Gan ada project yang udah jadinya gak ? :3 hehe
ReplyDelete