Hent form felt fra binary read
Mit spørgsmål er meget enkelt, hvordan henter jeg et form felt som er sendt til det understående script? Scriptet et upload script som bruger binary read.Function FileUpload(strProjectPath, intAcceptMaxSize, arrAcceptContentType, arrAcceptExt, arrAcceptDir, bolAutoCreateDir, bolAutoReplaceFile)
'** Variable deklaration **
Dim arrFileUploadStatusTxt 'Tekster der beskriver hvordan evt. upload gik
Dim arrSplit 'Array med data der er splitet på basis af en streng
Dim bolContentTypeOK 'Accept af ContentType
Dim bolDirOK 'Accept af Dir
Dim bolExtOK 'Accept af Ext
Dim bolFileUploadDone 'Een fil er uploaded
Dim bolMaxSizeOK 'Accept af filstørrelse
Dim bstrDivider 'delelinien inkl. vbCrLfB
Dim bstrPostData 'POST som binær streng
Dim i 'Tæller
Dim intEndPos 'Slutningen af denne Content del
Dim intFileTotalBytes 'Det faktiske antal bytes i filen
Dim intFileUploadStatus 'Tal der beskriver hvordan evt. upload gik
Dim intInStrPos 'Position der returneres fra InStr
Dim intPostTotalBytes 'Antallet af bytes i POST
Dim intStartPos 'Starten af denne Content del
Dim objFile 'FileObject
Dim objFSO 'FileSystemObject
Dim objOutputDict 'Dictionary der bruges til at returnere output
Dim objTS 'TextStreamObject
Dim strAcceptContentType 'Een af de ContentTyper der accepteres
Dim strAcceptDir 'Een af de Dir der accepteres
Dim strAcceptExt 'Een af de Ext der accepteres
Dim strContentDisposition 'Aktuelle Content-Disposition (uden vbCrLf)
Dim strContentType 'Aktuelle Content-Type (uden vbCrLf)
Dim strDestinationDir 'Den directory filen skal ende i (hentes fra form'en)
Dim strDestinationFileSpec 'FileSpec til destinationsfilen
Dim strDictItem 'Item tekst til Dictionary objekt
Dim strDictKey 'Nøgletekst til Dictionary objekt
Dim strExt 'Den fundne Ext
Dim strFilename 'Filnavn
Dim strFileSpec 'Absolut sti til filen i fileupload mappen
Dim strSourceFileSpec 'FileSpec itl sourcefilen
Dim vbCrLfB 'Som vbCrLf men som binær streng
'** Konstant deklaration **
Const FILEUPLOAD_DIR = "upload/nyheder/"
'** Check input **
'strProjectPath
If IsNull(strProjectPath) Or strProjectPath = "" Then
'Brug aktuelle scriptmappe som projektets rodmappe
strProjectPath = Request.ServerVariables("SCRIPT_NAME")
If InStrRev(strProjectPath, "/") > 0 Then
strProjectPath = Left(strProjectPath, InStrRev(strProjectPath, "/"))
End If
End If
If Right(strProjectPath, 1) <> "/" Then strProjectPath = strProjectPath & "/"
'intAcceptMaxSize
If IsNull(intAcceptMaxSize) Then intAcceptMaxSize = 0
If Not IsNumeric(intAcceptMaxSize) Then intAcceptMaxSize = 0
'arrAcceptContentType
If IsNull(arrAcceptContentType) Then arrAcceptContentType = Array("")
If Not IsArray(arrAcceptContentType) Then arrAcceptContentType = Array(arrAcceptContentType)
'arrAcceptExt
If IsNull(arrAcceptExt) Then arrAcceptExt = Array("")
If Not IsArray(arrAcceptExt) Then arrAcceptExt = Array(arrAcceptExt)
'arrAcceptDir
If IsNull(arrAcceptDir) Then arrAcceptDir = Array("")
If Not IsArray(arrAcceptDir) Then arrAcceptDir = Array(arrAcceptDir)
'bolAutoCreateDir
If IsNull(bolAutoCreateDir) Then bolAutoCreateDir = False
If bolAutoCreateDir <> True Then bolAutoCreateDir = False
'bolAutoReplaceFile
If IsNull(bolAutoReplaceFile) Then bolAutoReplaceFile = False
If bolAutoReplaceFile <> True Then bolAutoReplaceFile = False
'** Forbered diverse variabler **
intFileUploadStatus = 3 'Default svar er 3 Meddelelse: Der var ikke noget FILE felt med navnet FILEUPLOAD.
arrFileUploadStatusTxt = Array( "OK", _
"Fejl: Der var ingen data at hente.", _
"Fejl: Den samlede datamængde er ikke hentet korrekt.", _
"Info: Der var ikke noget FILE felt med navnet FILEUPLOAD.", _
"Fejl: Filen havde ikke noget filnavn.", _
"Fejl: Filen er for stor.", _
"Fejl: Content-Typen accepteres ikke.", _
"Fejl: Filens extension accepteres ikke.", _
"Fejl: Filen blev ikke gemt korrekt på serveren.", _
"Fejl: Filens destinationsmappe accepteres ikke.", _
"Fejl: Destinationsmappen findes ikke (og må ikke oprettes automatisk).", _
"Fejl: Destinationsfilen findes allerede (og må ikke slettes).", _
"Fejl: Filen kunne ikke flyttes til destinationsmappen.") 'Mulige svar
vbCrLfB = ChrB(13) & ChrB(10) 'Dan vbCrLf som binær streng
bolFileUploadDone = False
strDestinationDir = ""
'** Forbered output **
Set objOutputDict = CreateObject("Scripting.Dictionary")
'** Hent input fra strøm, dan output **
'Check: Er det faktisk POST upload?
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
'Hent den binære POST fra brugeren
intPostTotalBytes = Request.TotalBytes 'Find antallet af bytes i POST
bstrPostData = Request.BinaryRead(intPostTotalBytes) 'Hent POST til en binær streng
'Check: Er antallet af bytes i POST lig med længden af den binære streng?
If LenB(bstrPostData) = intPostTotalBytes Then
'Hent delelinien inkl. vbCrLfB (altid hele første linie)
bstrDivider = LeftB(bstrPostData, InStrB(bstrPostData, vbCrLfB) + 1)
'Løkke der finder og behandler alle Content-Disposition, Content-Type og Content-Data
intStartPos = 1
Do
'Find starten af denne Content del (umiddelbart efter delelinien)
intStartPos = InStrB(intStartPos, bstrPostData, bstrDivider) + LenB(bstrDivider)
If intStartPos = 0 Then
'Ikke flere Content delelinier
Exit Do
End If
'Find slutningen af denne Content del (umiddelbart inden den næste delelinie)
intEndPos = InStrB(intStartPos, bstrPostData, bstrDivider)
If intEndPos = 0 Then
'Ikke flere Content delelinier
Exit Do
End If
'Hent aktuelle Content-Disposition som LCase (uden vbCrLf)
strContentDisposition = LCase(bin2str(MidB(bstrPostData, intStartPos, InStrB(intStartPos, bstrPostData, vbCrLfB) - intStartPos)))
'Flyt intStartPos til efter Content-Disposition linien (altså til starten af Content-Type linien)
intStartPos = intStartPos + Len(strContentDisposition) + 2
'Hent aktuelle Content-Type som LCase (uden vbCrLf)
strContentType = LCase(bin2str(MidB(bstrPostData, intStartPos, InStrB(intStartPos, bstrPostData, vbCrLfB) - intStartPos)))
'Flyt intStartPos til starten af Content-Data
If strContentType = "" Then
'Flyt intStartPos til efter den ekstra blanke linie
intStartPos = intStartPos + 2
Else
'Flyt intStartPos til efter Content-Type linien og den ekstra blanke linie
intStartPos = intStartPos + Len(strContentType) + 4
End If
'Flyt intEndPos til slutningen af Content-Data (før den efterstillede vbCrLfB)
intEndPos = intEndPos - 2
'Undersøg om det er et fileupload felt eller et almindeligt form felt?
If InStr(strContentDisposition, "name=""fileupload") > 0 Then
'Er det et _dir felt?
If InStr(strContentDisposition, "name=""fileupload_dir""") > 0 Then
'**********************************
'***** Husk dir'en til senere *****
'**********************************
'Hent Content-Data som streng
strDestinationDir = LCase(bin2str(MidB(bstrPostData, intStartPos, intEndPos - intStartPos)))
'Er det et _file felt?
ElseIf InStr(strContentDisposition, "name=""fileupload_file""") > 0 Then
'*********************************
'***** Gem filen på serveren *****
'*********************************
'Der må ikke allerede være uploaded een fil
If Not bolFileUploadDone Then
'** Ekstrakt POST filnavnet fra Content-Disposition ***
'Opdel strContentDisposition ved ;: Content-Disposition: form-data; name="fileupload"; filename="filen.ext"
arrSplit = Split(strContentDisposition, ";")
'Find filnavnet fra filename= array
strFilename = "" 'Værdi ved fejl
For i = 0 To UBound(arrSplit) 'Køres for alle i denne array
If LCase(Left(Trim(arrSplit(i)), 9)) = "filename=" Then 'Står der filename= ?
strFilename = Trim(arrSplit(i))
Exit For
End If
Next
'Blev der fundet et filnavn?
If strFilename <> "" And strFilename <> "filename=""""" Then
'Find filnavnet
arrSplit = Split(strFilename, """") 'Opdel streng ved "
strFilename = arrSplit(UBound(arrSplit) - 1) 'Næstsidste indholder filnavn
arrSplit = Split(strFilename, "\") 'Del ved alle \ Så indeholder den sidste filnavn.ext"
strFilename = arrSplit(UBound(arrSplit)) 'Hent den sidste array, der må være filnavnet
strFilename = right(strFilename,4)
strFilename = Session("id") & "_" & Request.QueryString("id") & strFilename
'Indsætter filnavn i database under brugere
'If Request.QueryString("id") = "small" Then
Conn.Execute("UPDATE brugere SET smallpic = '" & Session("id") & "_" & "small" & "' WHERE id = " & Session("id") & "")
'ElseIf Request.QueryString("id") = "big" Then
'Conn.Execute("UPDATE brugere SET bigpic = '" & Session("id") & "_" & "big" & "' WHERE id = " & Session("id") & "")
'End If
'Autoopret evt. strProjectPath & FILEUPLOAD_DIR
AutoCreateDir LCase(strProjectPath & FILEUPLOAD_DIR)
'Dan det fulde outputfilnavn via MapPath
strFileSpec = Server.MapPath(LCase(strProjectPath & FILEUPLOAD_DIR & strFilename))
'Find det samlede antal bytes for filen
intFileTotalBytes = intEndPos - intStartPos
'Ekstrakt oplysninger om Content-Type: image/gif
arrSplit = Split(strContentType, " ")
strContentType = arrSplit(UBound(arrSplit))
'Skal MaxSize checkes?
bolMaxSizeOK = False
If intAcceptMaxSize > 0 Then
If intFileTotalBytes <= intAcceptMaxSize Then
bolMaxSizeOK = True
End If
Else
bolMaxSizeOK = True
End If
'Skal Content-Type checkes?
bolContentTypeOK = False
If arrAcceptContentType(LBound(arrAcceptContentType)) <> "" Then
For Each strAcceptContentType In arrAcceptContentType
If strContentType = strAcceptContentType Then
bolContentTypeOK = True
End If
Next
Else
bolContentTypeOK = True
End If
'Skal Ext checkes?
bolExtOK = False
If arrAcceptExt(LBound(arrAcceptExt)) <> "" Then
For Each strAcceptExt In arrAcceptExt
If LCase(Right(strFilename, Len(strAcceptExt))) = strAcceptExt Then
strExt = strAcceptExt
bolExtOK = True
End If
Next
Else
bolExtOK = True
End If
'Gå videre hvis de tre checks gik godt
If bolMaxSizeOK And bolContentTypeOK And bolExtOK Then
'Åbn, skriv og luk outputfilen
Set objFSO = CreateObject("Scripting.FileSystemObject") 'Filsystem objekt
Set objTS = objFSO.CreateTextFile(strFileSpec, True) 'Åbn outputfil, overskriv evt. eksisterende
For i = intStartPos To intEndPos - 1
objTS.Write(Chr(AscB(MidB(bstrPostData, i, 1)))) 'Skriv data eet tegn af gangen
Next
objTS.Close 'Luk outputfil
'Check: Blev filen oprettet og har den samme størrelse?
Set objFile = objFSO.GetFile(strFileSpec)
If objFile.Size = intFileTotalBytes Then
'Gem oplysninger om filen i Dictionary
objOutputDict("FILEUPLOAD_DIR") = FILEUPLOAD_DIR
objOutputDict("FILEUPLOAD_FILENAME") = Session("id") & "_" & strFilename
objOutputDict("FILEUPLOAD_URL") = LCase(strProjectPath & FILEUPLOAD_DIR & Session("id") & "_" & strFilename)
objOutputDict("FILEUPLOAD_SIZE") = intFileTotalBytes
objOutputDict("FILEUPLOAD_CONTENTTYPE") = strContentType
objOutputDict("FILEUPLOAD_EXT") = strExt
'* Status 0: OK
intFileUploadStatus = 0
'Begræns til een og kun een fil
bolFileUploadDone = True
Else
'Fejl 8: Filen blev ikke gemt korrekt på serveren
intFileUploadStatus = 8
End If
'Slip objekter
Set objFile = Nothing
Set objTS = Nothing
Set objFSO = Nothing
Else
'MaxSize, ContentType eller Ext var ikke ok
If Not bolMaxSizeOK Then
'* Fejl 5: Filen er for stor
intFileUploadStatus = 5
ElseIf Not bolContentTypeOK Then
'* Fejl 6: Content-Typen accepteres ikke
intFileUploadStatus = 6
ElseIf Not bolExtOK Then
'* Fejl 7: Filens extension accepteres ikke
intFileUploadStatus = 7
End If
End If
Else
'Fejl 4: Filen havde ikke noget filnavn.
intFileUploadStatus = 4
End If
End If
End If
Else
'**************************************************
'***** Gem oplysningerne om Content i objDict *****
'**************************************************
'Ekstrakt NAME fra Content-Type til strDictKey
'Find NAME eller returner hele Content-Typen
intInStrPos = InStr(strContentDisposition, "name=")
If intInStrPos > 0 Then
strDictKey = Mid(strContentDisposition, intInStrPos + 6)
strDictKey = Left(strDictKey, Len(strDictKey) - 1)
Else
strDictKey = strContentDisposition
End If
'Returner altid feltnavne som uppercase!
strDictKey = UCase(strDictKey)
'Hent Content-Data som streng
strDictItem = bin2str(MidB(bstrPostData, intStartPos, intEndPos - intStartPos))
'Tilføj til dictionary objekt ( = notationen retter/opretter automatisk)
objOutputDict(strDictKey) = strDictItem
End If
'Start igen umiddelbart efter denne Content, men før næste divider
intStartPos = intEndPos
Loop
'** Flyt evt. filen til en anden mappe **
If intFileUploadStatus = 0 Then
'Er der fundet en destinations mappe
If strDestinationDir <> "" Then
'DestinationDir skal slutte på /
If Right(strDestinationDir, 1) <> "/" Then
strDestinationDir = strDestinationDir & "/"
End If
'Skal Dir checkes?
bolDirOK = False
If arrAcceptDir(LBound(arrAcceptDir)) <> "" Then
For Each strAcceptDir In arrAcceptDir
'AcceptDir skal slutte på /
If Right(strAcceptDir, 1) <> "/" Then
strAcceptDir = strAcceptDir & "/"
End If
If LCase(strAcceptDir) = strDestinationDir Then
bolDirOK = True
End If
Next
Else
bolDirOK = True
End If
'Gik Dir checket godt?
If bolDirOK Then
'Findes mappen ikke?
If Not CheckDir(strProjectPath & strDestinationDir) Then
'Skal mappen oprettes?
If bolAutoCreateDir Then
'Opret mappen
AutoCreateDir strProjectPath & strDestinationDir
End If
End If
'Findes mappen nu?
If CheckDir(strProjectPath & strDestinationDir) Then
'Forbered et FSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Find filespecs
strSourceFileSpec = Server.MapPath(strProjectPath & FILEUPLOAD_DIR & strFilename)
strDestinationFileSpec = Server.MapPath(strProjectPath & strDestinationDir & strFilename)
'Er filespecs forskellige?
If strSourceFileSpec <> strDestinationFileSpec Then
'Findes destinationsfilen i forvejen?
If objFSO.FileExists(strDestinationFileSpec) Then
'Må filen slettes?
If bolAutoReplaceFile Then
'Slet filen
objFSO.DeleteFile strDestinationFileSpec
Else
'* Fejl 11: Destinationsfilen findes allerede (og må ikke slettes)
intFileUploadStatus = 11
End If
End If
'Er destinationsfilen væk?
If Not objFSO.FileExists(strDestinationFileSpec) Then
'Flyt filen fra kilde (fileupload) mappen til destinations mappen
objFSO.MoveFile strSourceFileSpec, strDestinationFileSpec
'Fejlmeld hvis det ikke gik godt
If Not objFSO.FileExists(strDestinationFileSpec) Then
'* Fejl 12: Filen kunne ikke flyttes til destinationsmappen
intFileUploadStatus = 12
End If
Else
'* Fejl 11: Destinationsfilen findes allerede (og må ikke slettes)
intFileUploadStatus = 11
End If
Else
'Kilde og Destination er een og samme fil (strDestinationDir = FILEUPLOAD_DIR
Rem
End If
Else
'Fejl 10: Destinationsmappen findes ikke (og må ikke oprettes automatisk)
intFileUploadStatus = 10
End If
Else
'* Fejl 9: Filens destinationsmappe accepteres ikke
intFileUploadStatus = 9
'Returner standardmappen
strDestinationDir = FILEUPLOAD_DIR
End If
Else
'Hvis strDestinationDir = "" returneres standardmappen
strDestinationDir = FILEUPLOAD_DIR
End If
'Opdater FILEUPLOAD_DIR og FILEUPLOAD_URL
objOutputDict("FILEUPLOAD_DIR") = strDestinationDir
objOutputDict("FILEUPLOAD_URL") = LCase(strProjectPath & strDestinationDir & strFilename)
End If
Else
'Fejl 2: Den samlede datamængde er ikke hentet korrekt.
intFileUploadStatus = 2
End If
Else
'Fejl 1: Der var ingen data at hente.
intFileUploadStatus = 1
End If
'Sæt status i dictionary objektet
objOutputDict("FILEUPLOAD_STATUS") = intFileUploadStatus
objOutputDict("FILEUPLOAD_STATUSTXT") = arrFileUploadStatusTxt(intFileUploadStatus)
'Returner dictionary output objekt
Set FileUpload = objOutputDict
End Function
'* Funktion der oversætter en bstr binær streng til en almindelig streng
'* Pas på med 00 værdier, da de fungerer som EOF i en almindelig streng
Function bin2str(bstrBinary)
Dim i
For i = 1 To LenB(bstrBinary)
bin2str = bin2str & Chr(AscB(MidB(bstrBinary, i, 1)))
Next
End Function
'* Procedure der automatisk opretter manglende mapper på en sti
'* Input: strPath = Fuld sti der skal oprettes, f.eks. "/projekt/abc/def/"
Public Sub AutoCreateDir(ByVal strPath)
Dim arrDirs
Dim objFSO
Dim strCurrentPath
Dim strCurrentSpec
Dim strDir
'Initialiser variabler
strCurrentPath = ""
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Check og ret input
If Left(strPath, 1) = "/" Then strPath = Right(strPath, Len(strPath) - 1)
If Right(strPath, 1) = "/" Then strPath = Left(strPath, Len(strPath) - 1)
'Findes ikke mappen allerede?
If Not objFSO.FolderExists(Server.MapPath("/" & strPath)) Then
'Fordel de enkelte mapper ud i en array
arrDirs = Split(strPath, "/")
'Gennemløb alle mapper i arrDirs fra roden og op
For Each strDir In arrDirs
'Tilføj denne mappe til den fulde sti
strCurrentPath = strCurrentPath & "/" & strDir
'Find spec for denne mappe
strCurrentSpec = Server.MapPath(strCurrentPath)
'Findes mappen ikke allerede?
If Not objFSO.FolderExists(strCurrentSpec) Then
'Opret da mappen
objFSO.CreateFolder(strCurrentSpec)
End If
Next
'Frigiv objekter
Set objFSO = Nothing
End If
End Sub
'* Funktion der checker om en path til en mappe (uden host) findes
'* Input: strPath = Sti der skal checkes, f.eks. "/projekt/abc/def/"
Public Function CheckDir(ByVal strPath)
Dim bolOutput
Dim objFSO
Dim strFolderSpec
'Check og ret input
If Right(strPath, 1) <> "/" Then strPath = strPath & "/"
'Find mappens spec
strFolderSpec = Server.MapPath(strPath)
'Check om mappen findes
Set objFSO = CreateObject("Scripting.FileSystemObject")
bolOutput = objFSO.FolderExists(strFolderSpec)
Set objFSO = Nothing
'Returner sand/falsk
CheckDir = bolOutput
End Function
Tak for hjælpen
//Hjalte
