Upload com AspJpeg

marciolvs · Fevereiro 11, 2013

Pessoal, to a 2 dias na guerra com um upload.

peguei um site para corrigir alguns erros e reformular algumas partes.

Nele possui um tipo de upload e nele o arquivo é renomeado e salvo no bd, at´ai tudo bem.

Porem me parece uma parte que eu não sei o que significa, parece que ele coia do local e manda para outras pastas, alguem pode me ajudar ?

Dim PastadeDestino, Pasta,cat_id,cat_id2,cat_id1


cat_id = Request.QueryString("folder")


cat_id=Replace(cat_id, "DOMINIO", "", 1, -1, 1)
cat_id=Replace(cat_id, "admin", "", 1, -1, 1)
cat_id=Replace(cat_id, "httpdocs", "", 1, -1, 1)
cat_id=Replace(cat_id, "/", "", 1, -1, 1)


dim vetor
vetor=array()
vetor=cat_id
vetor = Split(vetor,"-")
cat_id=vetor(0)
cat_id2=vetor(1)


if cat_id="S" then
Pasta = "admin/fotos/g"
else
Pasta = "admin/fotos2"
end if


PastadeDestino = Server.mapPath(Pasta)


Dim Form: Set Form = New ASPForm %>
<!--#INCLUDE FILE="./upload.asp"-->
<% 


Server.ScriptTimeout = 2000
Form.SizeLimit = &HA00000


If Form.State = 0 Then
  Dim File, NomedoArquivo,strFN,fso,f1
  For Each File In Form.Files.Items
If Len(File.FileName) > 0 Then
        NomedoArquivo = ArquivoNomeUnico(DecodeUTF8(File.FileName), PastadeDestino)


        File.SaveAs PastadeDestino & "\" & DecodeUTF8(NomedoArquivo)


set con = Server.CreateObject("ADODB.Connection")
con.ConnectionString = "Driver={SQL Server};Server=MEUSERVIDOR;Database=MEUBANCO;Uid=MEUUSUARIO;Pwd=MINHASENHA;" 
con.open


dim busca_user
set busca_user = con.execute("select max(id) as novoid from foto3")


'nome = "imagem"&day(now)&"_"&hour(now)&"_"&minute(now)&"_"&second(now)&".jpg"
nome="imagem_"&busca_user("novoid")+1&".jpg"


        if cat_id="S" then


        renomeiafoto "admin/fotos/g/"&DecodeUTF8(NomedoArquivo),"admin/fotos/g/"&nome
'não sei o que estas 3 linhas faz
AspJpeg "admin/fotos/g/","admin/fotos/g/",nome,1,300,600,100,130
AspJpeg2 "admin/fotos/g/","admin/fotos/",nome,1,300,338,100,130
AspJpeg2 "admin/fotos/g/","admin/fotos/p/",nome,1,100,95,100,130


con.Execute("INSERT INTO foto3(id,foto,legenda,anuncio_id,dt_cad,disp,ordena,numera) VALUES ('"&busca_user("novoid")+1&"','"&nome&"','SEM LEGENDA',"&cat_id2&",'"&Now&"','"&cat_id&"',1,1)")


        else


        renomeiafoto "admin/fotos2/"&DecodeUTF8(NomedoArquivo),"admin/fotos2/"&nome


        if cat_id="L" then
AspJpeg2 "admin/fotos2/","admin/fotos2/",nome,2,100,600,100,130
        else
        AspJpeg2 "admin/fotos2/","admin/fotos2/",nome,1,450,338,100,130
        end if


        set busca_user = con.execute("select max(id) as novoid from foto")
con.Execute("INSERT INTO foto(id,foto,legenda,anuncio_id,dt_cad,disp,ordena,tipo) VALUES('"&busca_user("novoid")+1&"','"&nome&"','SEM LEGENDA',"&cat_id2&",'"&Now&"','S',1,'"&cat_id&"')")


        end if


        con.Close
        set con = Nothing


        Response.Write "<br>Arquivo salvo em <b>" & PastadeDestino & "</b> com o nome de <b>" & NomedoArquivo & "</b>"


       End If

a parte que eu não sei o que significa é esta.

'não sei o que estas 3 linhas faz
AspJpeg "admin/fotos/g/","admin/fotos/g/",nome,1,300,600,100,130
AspJpeg2 "admin/fotos/g/","admin/fotos/",nome,1,300,338,100,130
AspJpeg2 "admin/fotos/g/","admin/fotos/p/",nome,1,100,95,100,130

Ronaldo Faria Storck Eler · Fevereiro 11, 2013

Qual o conteúdo do upload.asp (include)?

não sei como foi instanciado o ASPJpeg, mas, aparentemente, ele está pegando a foto, e gerando fotos de 3 tamanhos, provavelmente, para serem usadas em lugares diferentes no site, deve estar utilizando a função de crop (cortar)...

http://www.aspjpeg.com/manual_04.html

marciolvs · Fevereiro 11, 2013

Ronaldo, pelo que percebi analisando hoje, ele está pegando a imagem já salva e criando cópia em outras medidas em outras pastas.

Mas neste caso ele dá o erro, só não sei se é pq o componente está desconfigurado ou é alguma permissão.

xanburzum · Fevereiro 11, 2013

isso pode ser um redimensionamento das imagens passando os parametros

nome,1,300,600,100,130

AspJpeg "admin/fotos/g/","admin/fotos/p/",nome,1,300,600,100,130

verifique o que tem na pasta admin/fotos/g/ e admin/fotos/p/. E provavelmente dentro do include upload.asp tem a função

AspJpeg , dá uma olhada nela

marciolvs · Fevereiro 11, 2013

isso pode ser um redimensionamento das imagens passando os parametros
nome,1,300,600,100,130
AspJpeg "admin/fotos/g/","admin/fotos/p/",nome,1,300,600,100,130
verifique o que tem na pasta admin/fotos/g/ e admin/fotos/p/. E provavelmente dentro do include upload.asp tem a função
AspJpeg , dá uma olhada nela

na pasta g, a imagem salva normal, ai acredito que o erro dá quando ele manda para a p/, a include upload.asp é só função, mas não fala nada sobre as pastas

segue upload.asp

<!--
Arquivo original baixado do endereço http://www.uploadify.com/

Originalmente apenas era possível a utilização de PHP.
Fiz muitas buscas mas somente encontrei PHP e outras linguagens que NÃO ASP.

http://www.valterfurtado.com/blog
valter@valterfurtado.com

26 de novembro de 2009
Vitória - ES/Brasil
-->
<%
Const adTypeBinary = 1
Const adTypeText = 2


Const xfsCompleted    = &H0 '0  Form was successfully processed. 
Const xfsNotPost      = &H1 '1  Request method is NOT post 
Const xfsZeroLength   = &H2 '2  Zero length request (there are no data in a source form) 
Const xfsInProgress   = &H3 '3  Form is in a middle of process. 
Const xfsNone         = &H5 '5  Initial form state 
Const xfsError        = &HA '10  
Const xfsNoBoundary   = &HB '11  Boundary of multipart/form-data is not specified. 
Const xfsUnknownType  = &HC '12  Unknown source form (Content-type must be multipart/form-data) 
Const xfsSizeLimit    = &HD '13  Form size exceeds allowed limit (ScriptUtils.ASPForm.SizeLimit) 
Const xfsTimeOut      = &HE '14  Upload time exceeds allowed limit (ScriptUtils.ASPForm.ReadTimeout) 
Const xfsNoConnected  = &HF '15  Client was disconnected before upload was completted.
Const xfsErrorBinaryRead = &H10 '16  Unexpected error from Request.BinaryRead method (ASP error).

Class ASPForm
	Private m_ReadTime
	'////////////////////////
	'Gets & Sets
	'///////////////////////
	Public ChunkReadSize, BytesRead, TotalBytes, UploadID
	Public TempPath, MaxMemoryStorage, CharSet, FormType, SourceData, ReadTimeout
	public Default Property Get Item(Key)
		Read
		Set Item = m_Items.Item(Key)
	End Property
	public Property Get Items
		Read
		Set Items = m_Items
	End Property
	public Property Get Files
		Read
		Set Files = m_Items.Files
	End Property
	public Property Get Texts
		Read
		Set Texts = m_Items.Texts
	End Property
	public Property Get NewUploadID
		Randomize
		NewUploadID = clng(rnd * &H7FFFFFFF)
	End Property
	Public Property Get ReadTime
		if isempty(m_ReadTime) then
			if not isempty(StartUploadTime) then ReadTime = Clng((Now() - StartUploadTime) * 86400 * 1000)
		else ' For progress window.
			ReadTime = m_ReadTime
		end if
	End Property
	Public Property Get State
		if m_State = xfsNone Then Read
		State = m_State
	End Property
	'/////////////////////////
	Private Function CheckRequestProperties
	  If UCase(Request.ServerVariables("REQUEST_METHOD")) <> "POST" Then
			m_State = xfsNotPost 
			Exit Function
		End If
	
		Dim CT
		CT = Request.ServerVariables("HTTP_Content_Type")
		if len(CT) = 0 then CT = Request.ServerVariables("CONTENT_TYPE")
	  If LCase(Left(CT, 19)) <> "multipart/form-data" Then
			m_State = xfsUnknownType 
			Exit Function
		End If

		Dim PosB 
		PosB = InStr(LCase(CT), "boundary=")
		If PosB = 0 Then
			m_State = xfsNoBoundary
			Exit Function
		End If
		If PosB > 0 Then Boundary = Mid(CT, PosB + 9)

		'****** Erros de IE5
		PosB = InStr(LCase(CT), "boundary=") 
		If PosB > 0 then
			PosB = InStr(Boundary, ",")
			If PosB > 0 Then Boundary = Left(Boundary, PosB - 1)
		end if

		On Error Resume next
		TotalBytes = Request.TotalBytes
		If Err<>0 Then
			'Para UNIX/Linux 
			TotalBytes = CLng(Request.ServerVariables("HTTP_Content_Length"))
			if len(TotalBytes)=0 then TotalBytes = CLng(Request.ServerVariables("CONTENT_LENGTH"))
		End If
		
		If TotalBytes = 0 then
			m_State = xfsZeroLength 
			Exit Function
		End If

		If IsInSizeLimit(TotalBytes) Then
			CheckRequestProperties = True
			m_State = xfsInProgress 
		Else
			m_State = xfsSizeLimit	
		End if

	End Function

	Public Sub Read()
		if m_State <> xfsNone Then Exit Sub
		If Not CheckRequestProperties Then 
			WriteProgressInfo
			Exit Sub
		End If
		if isempty(bSourceData) then Set bSourceData = createobject("ADODB.Stream")
		bSourceData.Open
		bSourceData.Type = 1

		Dim DataPart, PartSize
		BytesRead = 0
		StartUploadTime = Now

		Do While BytesRead < TotalBytes
			PartSize = ChunkReadSize
			if PartSize + BytesRead > TotalBytes Then PartSize = TotalBytes - BytesRead
			DataPart = Request.BinaryRead(PartSize)
			BytesRead = BytesRead + PartSize

			bSourceData.Write DataPart

			WriteProgressInfo

			If Not Response.IsClientConnected Then
				m_State = xfsNoConnected  
				Exit Sub
			End If
		Loop
		m_State = xfsCompleted

		ParseFormData
	End Sub

	Private Sub ParseFormData
		Dim Binary
		bSourceData.Position = 0
		Binary = bSourceData.Read
		m_Items.mpSeparateFields Binary, Boundary
	End Sub
	Public Function getForm(FormID)
		if isempty(ProgressFile.UploadID) Then 'Was UploadID of ProgressFile set?
			ProgressFile.UploadID = FormID
		End If

		Dim ProgressData
		
		ProgressData = ProgressFile
		
		if len(ProgressData) > 0 then
			if ProgressData = "DONE" Then
				ProgressFile.Done
				Err.Raise 1, "getForm", "Upload was done"
			Else
				ProgressData = Split (ProgressData, vbCrLf)
				if ubound(ProgressData) = 3 Then
					m_State = clng(ProgressData(0))
					TotalBytes = clng(ProgressData(1))
					BytesRead = clng(ProgressData(2))
					m_ReadTime = clng(ProgressData(3))
				End If
			End If
		end if
		Set getForm = Me
	End Function
	Private Sub WriteProgressInfo
		If UploadID > 0 Then
			if isempty(ProgressFile.UploadID) Then
				ProgressFile.UploadID = UploadID
			End If

			Dim ProgressData, FileName
			ProgressData = m_State & vbCrLf & TotalBytes & vbCrLf & BytesRead & vbCrLf & ReadTime
			ProgressFile.Contents = ProgressData
		End If
	End Sub

	'Cria o ASPForm
	Private Sub Class_Initialize()
		ChunkReadSize = &H10000 '64 kB
		SizeLimit = &H100000 '1MB

		BytesRead = 0
		m_State = xfsNone
		
		TotalBytes = Request.TotalBytes

		Set ProgressFile = New cProgressFile
		Set m_Items = New cFormFields
	End Sub

	'Destrói o ASPForm
	Private Sub Class_Terminate()
		If UploadID > 0 Then
			ProgressFile.Contents = "DONE"
		End If
	End Sub

	Private Function IsInSizeLimit(TotalBytes)
		IsInSizeLimit = (m_SizeLimit = 0 or m_SizeLimit > TotalBytes) and (MaxLicensedLimit > TotalBytes)
	End Function

	Public Property Get SizeLimit
		SizeLimit = m_SizeLimit
	End Property 

	Public Property Let SizeLimit(NewLimit)
	'Verifica-se o tamanho do FORM
	if NewLimit > MaxLicensedLimit Then
			Err.Raise 1, "Limite de Tamanho", "Esta versão está limitada em no máximo 10MB (" & MaxLicensedLimit & "B)"
			m_SizeLimit = MaxLicensedLimit
		Else
			m_SizeLimit = NewLimit
		end if
	End Property 

	Public Boundary
	Private m_Items 
	Private m_State
	Private m_SizeLimit 'Define o limite do tamanho do form
	Private bSourceData 'ADODB.Stream
	Private StartUploadTime , TempFiolder 
	Private ProgressFile 'Arquivo com a descrição do progresso
End Class 'ASPForm
Const MaxLicensedLimit = &HA00000


'************************************************************************
Class cFormFields
	Dim m_Keys()
	Dim m_Items()
	Dim m_Count
	Public Default Property Get Item(ByVal Key)
		If vartype(Key) = vbInteger or vartype(Key) = vbLong then
			'Numeric index
			if Key<1 or Key>m_Count Then Err.raise "Index out of bounds"
			Set Item = m_Items(Key-1)
			Exit Property
		end if

		Dim Count
		Count = ItemCount(Key)
		Key = LCase(Key)
		
		If Count > 0 then
			If Count>1 Then
				Dim OutItem, ItemCounter
				Set OutItem = New cFormFields
				ItemCounter = 0
				
				For ItemCounter = 0 To Ubound(m_Keys)
					If LCase(m_Keys(ItemCounter)) = Key then OutItem.Add Key, m_Items(ItemCounter)
				Next
				Set Item = OutItem
			Else 
				For ItemCounter = 0 To Ubound(m_Keys)
					If LCase(m_Keys(ItemCounter)) = Key then exit for
				Next

				if isobject (m_Items(ItemCounter)) then
					Set Item = m_Items(ItemCounter)
				else
					Item = m_Items(ItemCounter)
				end if
			End If
		Else
			Set Item = New cFormField
		End if
	End Property

	Public Property Get MultiItem(ByVal Key)
		Dim Out: Set Out = New cFormFields
		Dim I, vItem 
		Dim Count
		Count = ItemCount(Key)
		
		if Count = 1 then
			Out.Add Key, Item(Key)
		elseif Count > 1 then
			For Each I In Item(Key).Items
				Out.Add Key, I
			Next
		End If

		Set MultiItem = Out
	End Property

	'Para multiplos arquivos
	Public Property Get Value
		Dim I, V
		For Each I in m_Items
			V = V & ", " & I 
		Next
		V = Mid(V, 3)
		Value = V
	End Property


	Public Property Get xA_NewEnum
		Set xA_NewEnum = m_Items
	End Property

	Public Property Get Items()
		'Wscript.Echo "**cFormFields-Items"		
		Items = m_Items
	End Property

	Public Property Get Keys()
		Keys = m_Keys
	End Property

	public Property Get Files
		Dim cItem, OutItem, ItemCounter
		Set OutItem = New cFormFields 
		ItemCounter = 0
		if m_Count > 0 then ' Enumerate only non-empty form
			For ItemCounter = 0 To Ubound(m_Keys)
				Set cItem = m_Items(ItemCounter)
				if cItem.IsFile then
					OutItem.Add m_Keys(ItemCounter), m_Items(ItemCounter)
				end if
			Next
		End If
		Set Files = OutItem 
	End Property

	Public Property Get Texts
		Dim cItem, OutItem, ItemCounter
		Set OutItem = New cFormFields 
		ItemCounter = 0
		
		For ItemCounter = 0 To Ubound(m_Keys)
			Set cItem = m_Items(ItemCounter)
			if Not cItem.IsFile then
				OutItem.Add m_Keys(ItemCounter), m_Items(ItemCounter)
			end if
		Next
		Set Texts = OutItem
	End Property

	Public Sub Save(Path)
		Dim Item
		For Each Item In m_Items
			If Item.isFile Then
				Item.Save Path
			End If
		Next
	End Sub


	'Count of dictionary items within specified key
	Public Property Get ItemCount(ByVal Key)
		'wscript.echo "ItemCount"
		Dim cKey, Counter
		Counter = 0
		Key = LCase(Key)
		For Each cKey In m_Keys
			'wscript.echo "ItemCount", "cKey"
			If LCase(cKey) = Key then Counter = Counter + 1
		Next
		ItemCount = Counter
	End Property

	'Count of all dictionary items
	Public Property Get Count()
		Count = m_Count
	End Property

	Public Sub Add(byval Key, Item)
		Key = "" & Key
		ReDim Preserve m_Items(m_Count)
		ReDim Preserve m_Keys(m_Count)
		m_Keys(m_Count) = Key
		Set m_Items(m_Count) = Item
		m_Count = m_Count + 1
	End Sub

	Private Sub Class_Initialize()
		Dim vHelp()
		' I do not know why, but some of VBS verrsions declares m_Items and m_Keys as Empty,
		' not as Variant() - see class variables.
		' vHelp eliminates this problem. V. 2.03, 2.04
		On Error Resume Next
		m_Items = vHelp
		m_Keys = vHelp
		m_Count = 0
	End Sub


	'********************************** mpSeparateFields **********************************
	'This method retrieves the upload fields from binary data 
	'Binary is safearray ( VT_UI1 | VT_ARRAY ) of all multipart document raw binary data from input.
	Public Sub mpSeparateFields(Binary, ByVal Boundary)
		Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary

		Boundary = "--" & Boundary			
		Boundary = StringToBinary(Boundary)

		PosOpenBoundary = InStrB(Binary, Boundary)
		PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)

		Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
			'Header and file/source field data
			Dim HeaderContent, bFieldContent
			'Header fields
			Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
			'Helping variables
			Dim 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), FormFieldName, SourceFileName, Content_Disposition, Content_Type

			'Create one field and assign parameters
			
			Dim Field        'All field values.
			Set Field = New cFormField

			Field.ByteArray = MultiByteToBinary(bFieldContent)

			Field.Name = FormFieldName
			Field.ContentDisposition = Content_Disposition
			if not isempty(SourceFileName) then
				Field.FilePath = SourceFileName
				Field.FileName = GetFileName(SourceFileName)
				Field.FileExt = GetFileExt(SourceFileName)
			else'if not isempty(SourceFileName) then
			End If'if not isempty(SourceFileName) then
			Field.ContentType = Content_Type
			
			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
	End Sub
End Class 'cFormFields











'This class transfers data between primary (upload) and secondary (progress) window.
Class cProgressFile
	Private fs
	Public TempFolder
	Public m_UploadID
	Public TempFileName

	Public Default Property Get Contents()
		Contents = GetFile(TempFileName)
	End Property

	Public Property Let Contents(inContents)
		WriteFile TempFileName, inContents
	End Property

	Public Sub Done 'Delete temporary file when upload was done.
		FS.DeleteFile TempFileName
	End Sub

	Public Property Get UploadID()
		UploadID = m_UploadID
	End Property

	Public Property Let UploadID(inUploadID)
		if isempty(FS) then Set fs = CreateObject("Scripting.FileSystemObject")
		TempFolder = fs.GetSpecialFolder(2)

		m_UploadID = inUploadID
		TempFileName = TempFolder & "\pu" & m_UploadID & ".~tmp"
		
		Dim DateLastModified
		on error resume next
		DateLastModified = fs.GetFile(TempFileName).DateLastModified
		on error goto 0
		if isempty(DateLastModified) then 'OK
		elseif Now-DateLastModified>1 Then 'I think upload duration will be less than one day
			FS.DeleteFile TempFileName
		end if
	End Property

	Private Function GetFile(Byref FileName)
		
		Dim InStream
		On Error Resume Next
		Set InStream = fs.OpenTextFile(FileName, 1)
		GetFile = InStream.ReadAll
		On Error Goto 0
	End Function

	Private Function WriteFile(Byref FileName, Byref Contents)
		'wscript.echo "WriteFile", FileName, Contents
		Dim OutStream
		On Error Resume Next
		Set OutStream = fs.OpenTextFile(FileName, 2, True)
		OutStream.Write Contents
	End Function


	Private Sub Class_Initialize()
	End Sub
End Class 'cProgressFile



'******************************************************************************
'Emulates ScriptUtilities FormField object
'See http://www.motobit.com
Class cFormField
	'Used properties
	Public ContentDisposition, ContentType, FileName, FilePath, FileExt, Name
	Public ByteArray

	'non-used properties.
	Public CharSet, HexString, InProgress, SourceLength, RAWHeader, Index, ContentTransferEncoding
 
	Public Default Property Get String()
		'wscript.echo "**Field-String", Name, LenB(ByteArray)
		String = BinaryToString(ByteArray)
	End Property 

	Public Property Get IsFile()
		IsFile = not isempty(FileName)
	End Property

	Public Property Get Length()
		Length = LenB(ByteArray)
	End Property

	Public Property Get Value()
		Set Value = Me
	End Property

	Public Sub Save(Path)
	  '2.06 - and len(FileName)>0
		if IsFile and len(FileName)>0 Then
			Dim fullFileName
			fullFileName = Path & "\" & FileName
			SaveAs fullFileName
		Else
			'response.write "<br>" & typename(Name)
			'Err.Raise 1, "Text field " & Name & " does not have a file name"
		End If
	End Sub

	Public Sub SaveAs(newFileName)
		'2.06 - removed if len(ByteArray)>0 then 
		SaveBinaryData newFileName, ByteArray
	End Sub
	
End Class























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

Function BinaryToString(Binary)
  '2001 Antonin Foller, Motobit Software
  'Optimized version of PureASP conversion function
  'Selects the best algorithm to convert binary data to String data
  Dim TempString 

  On Error Resume Next
  'Recordset conversion has a best functionality
  TempString = RSBinaryToString(Binary)
  If Len(TempString) <> LenB(Binary) then'Conversion error
    'We have to use multibyte version of BinaryToString
    TempString = MBBinaryToString(Binary)
  end if
  BinaryToString = TempString
End Function


Function MBBinaryToString(Binary)
  '1999 Antonin Foller, Motobit Software
  'MultiByte version of BinaryToString function
	'Optimized version of simple BinaryToString algorithm.
  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
  MBBinaryToString = pl1 & pl2 & pl3
End Function


Function RSBinaryToString(xBinary)
  '1999 Antonin Foller, Motobit Software
  'This function converts binary data (VT_UI1 | VT_ARRAY or MultiByte string)
	'to string (BSTR) using ADO recordset
	'The fastest way - requires ADODB.Recordset
	'Use this function instead of MBBinaryToString if you have ADODB.Recordset installed
	'to eliminate problem with PureASP performance

	Dim Binary
	'MultiByte data must be converted to VT_UI1 | VT_ARRAY first.
	if vartype(xBinary) = 8 then Binary = MultiByteToBinary(xBinary) else Binary = xBinary
	
  Dim RS, LBinary
  Const adLongVarChar = 201
  Set RS = CreateObject("ADODB.Recordset")
  LBinary = LenB(Binary)
	
	if LBinary>0 then
		RS.Fields.Append "mBinary", adLongVarChar, LBinary
		RS.Open
		RS.AddNew
			RS("mBinary").AppendChunk Binary 
		RS.Update
		RSBinaryToString = RS("mBinary")
	Else
		RSBinaryToString = ""
	End If
End Function


Function MultiByteToBinary(MultiByte)
  ' This function converts multibyte string to real binary data (VT_UI1 | VT_ARRAY)
  ' Using recordset
  Dim RS, LMultiByte, Binary
  Const adLongVarBinary = 205
  Set RS = CreateObject("ADODB.Recordset")
  LMultiByte = LenB(MultiByte)
	if LMultiByte>0 then
		RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
		RS.Open
		RS.AddNew
			RS("mBinary").AppendChunk MultiByte & ChrB(0)
		RS.Update
		Binary = RS("mBinary").GetChunk(LMultiByte)
	End If
  MultiByteToBinary = Binary
End Function



'************** Upload Utilities 
'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Name, FileName, Content_Disposition, Content_Type)
  'Get name of the field. Name is separated by name= and ;
  Name = (SeparateField(Head, "name=", ";")) 'ltrim
  'Remove quotes (if the field name is quoted)
  If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)

  'Same for source filename
  FileName = (SeparateField(Head, "filename=", ";")) 'ltrim

  If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)


  'Separate content-disposition and content-type header fields
  Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
  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

Function SplitFileName(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
	SplitFileName = PosF
End Function

Function GetPath(FullPath)
  GetPath = left(FullPath, SplitFileName(FullPath)-1)
End Function

'Separetes file name from the full path of file
Function GetFileName(FullPath)
  GetFileName = Mid(FullPath, SplitFileName(FullPath))
End Function

'Separetes file name from the full path of file
Function GetFileExt(FullPath)
	Dim Pos: Pos = InStrRev(FullPath,".")
	if Pos>0 then GetFileExt = Mid(FullPath, Pos)
End Function


Function RecurseMKDir(ByVal Path)
  Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
	
  Path = Replace(Path, "/", "\")
  If Right(Path, 1) <> "\" Then Path = Path & "\"   '"
  Dim Pos, n
  Pos = 0: n = 0
  Pos = InStr(Pos + 1, Path, "\")   '"
  Do While Pos > 0
    On Error Resume Next
    FS.CreateFolder Left(Path, Pos - 1)
    If Err = 0 Then n = n + 1
    Pos = InStr(Pos + 1, Path, "\")   '"
  Loop
  RecurseMKDir = n
End Function

Function SaveBinaryData(FileName, ByteArray)
	SaveBinaryData = SaveBinaryDataStream(FileName, ByteArray)
End Function

Function SaveBinaryDataTextStream(FileName, ByteArray)
  Dim FS : Set FS = CreateObject("Scripting.FileSystemObject")
	On error Resume next
  Dim TextStream 
	Set TextStream = FS.CreateTextFile(FileName)
	if Err = &H4c then 'Path not found.
		On error Goto 0
		RecurseMKDir GetPath(FileName)
		On error Resume next
		Set TextStream = FS.CreateTextFile(FileName)
	end if
  TextStream.Write BinaryToString(ByteArray) 'BinaryToString is in upload.inc.
  TextStream.Close

	Dim ErrMessage, ErrNumber
	ErrMessage = Err.Description
	ErrNumber = Err

	On Error Goto 0
	if ErrNumber<>0 then Err.Raise ErrNumber, "SaveBinaryData", FileName & ":" & ErrMessage 

End Function

Function SaveBinaryDataStream(FileName, ByteArray)
	Dim BinaryStream
	Set BinaryStream = createobject("ADODB.Stream")
	BinaryStream.Type = 1 'Binary
	BinaryStream.Open
	'2.06 - zero byte file is legal
	if lenb(ByteArray)>0 then BinaryStream.Write ByteArray
	On error Resume next
	
	BinaryStream.SaveToFile FileName, 2 'Overwrite

	if Err = &Hbbc then 'Path not found.
		On error Goto 0
		RecurseMKDir GetPath(FileName)
		On error Resume next
		BinaryStream.SaveToFile FileName, 2 'Overwrite
	end if
	Dim ErrMessage, ErrNumber
	
	ErrMessage = Err.Description
	ErrNumber = Err

	On Error Goto 0
	if ErrNumber<>0 then Err.Raise ErrNumber, "SaveBinaryData", FileName & ":" & ErrMessage 
	
End Function
'************** Upload Utilities - end

'Emulates response object
Class cResponse
	Public Property Get IsClientConnected
		randomize
		IsClientConnected = cbool(clng(rnd * 4))
		IsClientConnected = True
	End Property 
End Class 


Class cRequest
	Private Readed

	Private BinaryStream
	public function ServerVariables(Name)	
		select case UCase(Name) 
			Case "CONTENT_TYPE": 
			Case "HTTP_CONTENT_TYPE": 
				ServerVariables = "multipart/form-data; boundary=---------------------------7d21960404e2"
			Case "CONTENT_LENGTH": 
			Case "HTTP_CONTENT_LENGTH": 
				ServerVariables = "" & TotalBytes
			Case "REQUEST_METHOD": 
				ServerVariables = "POST"
		End Select
	End Function

	public function BinaryRead(ByRef Bytes)
		If Bytes<=0 then Exit Function

		if Readed + Bytes > TotalBytes Then Bytes = TotalBytes - Readed
		BinaryRead = BinaryStream.Read(Bytes)
	End Function

	Public Property Get TotalBytes
		TotalBytes = BinaryStream.Size
	End Property

	Private Sub Class_Initialize()
		Set BinaryStream = createobject("ADODB.Stream")
		BinaryStream.Type = 1 'Binary
		BinaryStream.Open
		BinaryStream.LoadFromFile "F:\InetPub\Motobit\pureupload\2.txt"
		BinaryStream.Position = 0
		Readed = 0
	End Sub
end Class



%>

os arquivos

e

são referente a ele dimencionar as imagens.

xanburzum · Fevereiro 11, 2013

qual o conteúdo de admin/fotos/p/

Ronaldo Faria Storck Eler · Fevereiro 11, 2013

Antes de continuar, já verificou se a pasta para onde ele está mandando as demais tem permissão de escrita? isso já aconteceu comigo algumas vezes, tentar resolver e na verdade era apenas uma permissão de escrita...

sds

xanburzum · Fevereiro 12, 2013

namaioria das vezes sendo premissão ele dá o erro 80004005

Ronaldo Faria Storck Eler · Fevereiro 12, 2013

Bom, se não está aparecendo nenhum erro, eu começaria a testar se todos os caminhos estão de acordo, e na função:

AspJpeg "admin/fotos/g/","admin/fotos/g/",nome,1,300,600,100,130

Penso que deveria verificar o caminho completo, dentro dessa função AspJpeg ou ver como o objeto foi instanciado, e como o caminho não está absoluto, verificar se onde este arquivo de upload está, tem essa pasta "admin/fotos/", tem que aparecer alguma mensagem ou algo do tipo para podermos ajudar melhor...

sds

xanburzum · Fevereiro 12, 2013

como eu disse no post #6 verifique o conteúdo que tem em admin/fotos/p/ se ele esta redimencionando a img

marciolvs · Fevereiro 12, 2013

qual o conteúdo de admin/fotos/p/

é uma pasta, tem apenas imagens

marciolvs · Fevereiro 13, 2013

Bom, se não está aparecendo nenhum erro, eu começaria a testar se todos os caminhos estão de acordo, e na função:
AspJpeg "admin/fotos/g/","admin/fotos/g/",nome,1,300,600,100,130
Penso que deveria verificar o caminho completo, dentro dessa função AspJpeg ou ver como o objeto foi instanciado, e como o caminho não está absoluto, verificar se onde este arquivo de upload está, tem essa pasta "admin/fotos/", tem que aparecer alguma mensagem ou algo do tipo para podermos ajudar melhor...

sds

Ronaldo Faria, verifiquei todo o diretorio, abri arquivo por arquivo e nada, tá complicado, será que pode ser permissão ?

xanburzum · Fevereiro 13, 2013

na duvida coloque as devidas permissões administrativas na pasta

marciolvs · Fevereiro 13, 2013

xanburzum, segundo o pessoal do servidor e o painel, já está com as pemissões.

xanburzum · Fevereiro 14, 2013

apenas para teste , tem um exemplo que postei de Upload com o ASPJpeg, execute-o e seja o resultado.

marciolvs · Fevereiro 14, 2013

apenas para teste , tem um exemplo que postei de Upload com o ASPJpeg, execute-o e seja o resultado.

me passe o link, pois não achei

Ronaldo Faria Storck Eler · Fevereiro 15, 2013

Qual é o servidor de hospedagem? eu tive problemas com o IPhotel, me disseram que estava tudo liberado, mas não funcionva... como uso o filezilla, setei as pemissoes por ele, e incrivelmente, funcionou...

sds

marciolvs · Fevereiro 15, 2013

Qual é o servidor de hospedagem? eu tive problemas com o IPhotel, me disseram que estava tudo liberado, mas não funcionva... como uso o filezilla, setei as pemissoes por ele, e incrivelmente, funcionou...

sds

o servidor que hospedo ele não tem como liberar pelo filezilla

Ronaldo Faria Storck Eler · Fevereiro 17, 2013

Bem, Marcio,

Vejamos, cole aqui a função "AspJpeg", pois o script chama está função (que não deve ser a instanciação do componente aspjpg) e vamos analisar como os parametros estão sendo incorporados, e ver se tem alguma coisa que podemos identificar...

sds

xanburzum · Fevereiro 17, 2013

executa este exemplo

<%
'Declara as variáveis a serem utilizadas no script
Dim AspJpeg, imagem
 
'Instancia o componente na memória
SET AspJpeg = Server.CreateObject("Persits.Jpeg")
 
'Define o caminho da imagem a ser redimensionada
imagem = "e:\home\pasta\web\AspJpeg\imagem.jpg"
  
'Carrega a imagem
AspJpeg.Open imagem
 
'Define o novo tamanho da imagem que neste caso, definimos que ela será 50% menor que o normal.
AspJpeg.Width = AspJpeg.OriginalWidth / 2
AspJpeg.Height = AspJpeg.OriginalHeight / 2
 
'Esse método é opcional, usado para melhorar o visual da imagem.
AspJpeg.Sharpen 1, 150
 
'Cria um Thumbnail e o grava no caminho abaixo.
AspJpeg.Save "e:\home\pasta\Web\AspJpeg\imagem_mini.jpg"
 
'Para quem utiliza serviços da REVENDA conosco
'AspJpeg.Save "E:\vhosts\pasta\httpdocs\AspJpeg\imagem_mini.jpg"
 
'Para enviar o thumbnail para o browser do visitante, utilize o método SendBinary .
Response.Write AspJpeg.SendBinary
 
'Remove as referências do componente da memória
SET AspJpeg = Nothing
%>

Arquivado

Upload com AspJpeg

Recommended Posts

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ronaldo Faria Storck Eler 2

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ronaldo Faria Storck Eler 2

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ronaldo Faria Storck Eler 2

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ronaldo Faria Storck Eler 2

Compartilhar este post

Link para o post

Compartilhar em outros sites

marciolvs 1

Compartilhar este post

Link para o post

Compartilhar em outros sites

Ronaldo Faria Storck Eler 2

Compartilhar este post

Link para o post

Compartilhar em outros sites

xanburzum 169