---
title: "Pure ASpUpload"
type: "forum-thread"
url: "https://www.webforum.nu/amne/asp/10198-pure-aspupload"
topic: "ASP"
topic_url: "https://www.webforum.nu/amne/asp"
author: "pellsäter"
published: "2001-06-23T07:48:00.000Z"
updated: "2001-06-23T07:48:00.000Z"
replies: 0
views: 170
page: 1
pages: 1
language: "sv-SE"
site: "webForum — webforum.nu"
rights: "Upphovsrätten till varje inlägg tillhör dess författare."
attribution: "Citera som: webForum, https://www.webforum.nu/amne/asp/10198-pure-aspupload"
---

# Pure ASpUpload

## #1 — pellsäter, 2001-06-23T07:48Z

Hej använder mig av PureAspUpload! 

KÄnner någon till den koden!! Jag skulle vilja lägga till så att det skapas ett filnamn i en databas för varje bild som läggs in!

\<%@LANGUAGE="VBSCRIPT"%\> \<%
'\*\*\* File Upload to: image_egnabilder, Extensions: "GIF,JPG,JPEG,BMP,PNG", Form: bild, Redirect: "laggtillbild2.asp"
'\*\*\* Pure ASP File Upload -----------------------------------------------------
' Copyright 2000 (c) George Petrov
'
' Script partially based on code from Philippe Collignon 
'              (http://www.asptoday.com/articles/20000316.htm)
'
' New features from GP:
'  \* Fast file save with ADO 2.5 stream object
'  \* new wrapper functions, extra error checking
'  \* UltraDev Server Behavior extension
'
' Version: 1.5.0
'------------------------------------------------------------------------------
Sub BuildUploadRequest(RequestBin)
  'Get the boundary
  PosBeg = 1
  PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))
  if PosEnd = 0 then
    Response.Write "\<b\>Formuläret är inte ett s.k. ENCTYPE=""multipart/form-data""\</b\>\<br\>"
    Response.Write "Rätta och försök igen"
    Response.End
  end if
  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))
      FileName = Mid(FileName,InStrRev(FileName,"\\")+1)
      '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 = FileName
      ValueBeg = PosBeg-1
      ValueLen = 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))
      ValueBeg = 0
      ValueEnd = 0
    End If
    'Add content to dictionary object
    UploadControl.Add "Value" , Value	
    UploadControl.Add "ValueBeg" , ValueBeg
    UploadControl.Add "ValueLen" , ValueLen	
    '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

Function UploadFormRequest(name)
  on error resume next
  if UploadRequest.Item(name) then
    UploadFormRequest = UploadRequest.Item(name).Item("Value")
  end if  
End Function

'Process the upload
UploadQueryString = Replace(Request.QueryString,"GP_upload=true","")
if mid(UploadQueryString,1,1) = "&" then
	UploadQueryString = Mid(UploadQueryString,2)
end if

GP_uploadAction = CStr(Request.ServerVariables("URL")) & "?GP_upload=true"
If (Request.QueryString \<\> "") Then  
  if UploadQueryString \<\> "" then
	  GP_uploadAction = GP_uploadAction & "&" & UploadQueryString
  end if 
End If

If (CStr(Request.QueryString("GP_upload")) \<\> "") Then
  GP_redirectPage = "laggtillbild.asp"
  If (GP_redirectPage = "") Then
    GP_redirectPage = CStr(Request.ServerVariables("URL"))
  end if
    
  RequestBin = Request.BinaryRead(Request.TotalBytes)
  Dim UploadRequest
  Set UploadRequest = CreateObject("Scripting.Dictionary")  
  BuildUploadRequest RequestBin
  
  GP_keys = UploadRequest.Keys
  for GP_i = 0 to UploadRequest.Count - 1
    GP_curKey = GP_keys(GP_i)
    'Save all uploaded files
    if UploadRequest.Item(GP_curKey).Item("FileName") \<\> "" then
      GP_value = UploadRequest.Item(GP_curKey).Item("Value")
      GP_valueBeg = UploadRequest.Item(GP_curKey).Item("ValueBeg")
      GP_valueLen = UploadRequest.Item(GP_curKey).Item("ValueLen")

      if GP_valueLen = 0 then
        Response.Write "\<B\>An error has occured saving uploaded file!\</B\>\<br\>\<br\>"
        Response.Write "Filename: " & Trim(GP_curPath) & UploadRequest.Item(GP_curKey).Item("FileName") & "\<br\>"
        Response.Write "File does not exists or is empty.\<br\>"
        Response.Write "Please correct and \<A HREF=""javascript:history.back(1)""\>try again\</a\>"
	  	  response.End
	    end if
      
      'Create a Stream instance
      Dim GP_strm1, GP_strm2
      Set GP_strm1 = Server.CreateObject("ADODB.Stream")
      Set GP_strm2 = Server.CreateObject("ADODB.Stream")
      
      'Open the stream
      GP_strm1.Open
      GP_strm1.Type = 1 'Binary
      GP_strm2.Open
      GP_strm2.Type = 1 'Binary
        
      GP_strm1.Write RequestBin
      GP_strm1.Position = GP_ValueBeg
      GP_strm1.CopyTo GP_strm2,GP_ValueLen
    
      'Create and Write to a File
      GP_curPath = Request.ServerVariables("PATH_INFO")
      GP_curPath = Trim(Mid(GP_curPath,1,InStrRev(GP_curPath,"/")) & "image_egnabilder")
      if Mid(GP_curPath,Len(GP_curPath),1) \<\> "/" then
        GP_curPath = GP_curPath & "/"
      end if  
      on error resume next
      GP_strm2.SaveToFile Trim(Server.mappath(GP_curPath))& "\\" & UploadRequest.Item(GP_curKey).Item("FileName"),2
      if err then
        Response.Write "\<B\>Bågot har gått fel vid själva processandet\</B\>\<br\>\<br\>"
        Response.Write "Filename: " & Trim(GP_curPath) & UploadRequest.Item(GP_curKey).Item("FileName") & "\<br\>"
        Response.Write "Kanske finns inte mappen du vill skriva till eller så har du inte skrivrättigheter\<br\>"
        Response.Write "Rätta och \<A HREF=""javascript:history.back(1)""\>försök igen\</a\>"
  		  err.clear
	  	  response.End
	    end if
    end if
  next
  
  '\*\*\*GP BEGIN REDIRECT:  with URL parameters (only if no Insert/Update)
  If (GP_redirectPage \<\> "") Then
    If (InStr(1, GP_redirectPage, "?", vbTextCompare) = 0 And UploadQueryString \<\> "") Then
      GP_redirectPage = GP_redirectPage & "?" & UploadQueryString
    End If
    Call Response.Redirect(GP_redirectPage)  
  end if  
  '\*\*\*GP END REDIRECT
end if  
if UploadQueryString \<\> "" then
  UploadQueryString = UploadQueryString & "&GP_upload=true"
else  
  UploadQueryString = "GP_upload=true"
end if  

%\>

Permalänk: https://www.webforum.nu/p/10198

---

Tråden på webben: https://www.webforum.nu/amne/asp/10198-pure-aspupload