Erro de tempo de execução do Microsoft VBScript erro '800a01a8&#39

[renercarvalho 0]

Pessoal, comprei uma loja virtual em asp e vez ou outra preciso resolver alguns problemas. Não sou programador, mas consigo me virar nas literaturas disponíveis. Porém ontem aconteceu um fato inusitado e não consigo resolver, por isso preciso da ajuda de vocês:

No meu cadastro de produtos, tem um código para adicionar a foto do produto ao seu cadastro. Até ontem havia cadastrado 1700 produtos sem problemas. Mas aí surgiu o erro mencionado, sem que tenha havido qualquer alteração no código. Seguem as linhas e o erro:

Agradeço a quem puder ajudar, pois estou com o cadastro de produtos parado por causa disso.

A linha 143 está destacada em negrito.

 

Erro de tempo de execução do Microsoft VBScript erro '800a01a8'

Objeto necessário: 'Item(...)'

/admin/upload_foto1.asp, linha 143

 

<%

Sub BuildUploadRequest(RequestBin)

PosBeg = 1

PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))

boundary = MidB(RequestBin,PosBeg,PosEnd-PosBeg)

boundaryPos = InstrB(1,RequestBin,boundary)

Do until (boundaryPos=InstrB(RequestBin,boundary & getByteString("--")))

Dim UploadControl

Set UploadControl = CreateObject("Scripting.Dictionary")

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)

If PosFile <> 0 AND (PosFile<PosBound) Then

PosBeg = PosFile + 10

PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(34)))

FileName = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))

UploadControl.Add "FileName", FileName

Pos = InstrB(PosEnd,RequestBin,getByteString("Content-Type:"))

PosBeg = Pos+14

PosEnd = InstrB(PosBeg,RequestBin,getByteString(chr(13)))

ContentType = getString(MidB(RequestBin,PosBeg,PosEnd-PosBeg))

UploadControl.Add "ContentType",ContentType

PosBeg = PosEnd+4

PosEnd = InstrB(PosBeg,RequestBin,boundary)-2

Value = MidB(RequestBin,PosBeg,PosEnd-PosBeg)

Else

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

UploadControl.Add "Value" , Value

UploadRequest.Add name, UploadControl

BoundaryPos=InstrB(BoundaryPos+LenB(boundary),RequestBin,boundary)

Loop

End Sub

Function getByteString(StringStr)

For i = 1 to Len(StringStr)

char = Mid(StringStr,i,1)

getByteString = getByteString & chrB(AscB(char))

Next

End Function

Function getString(StringBin)

getString =""

For intCount = 1 to LenB(StringBin)

getString = getString & chr(AscB(MidB(StringBin,intCount,1)))

Next

End Function

pasta_imagens = "../" & Request("pasta")

pasta = Server.URLEncode(Request("pasta"))

campo = Server.URLEncode(Request("campo"))

Set objFS = Server.CreateObject("Scripting.FileSystemObject")

If Not objFS.FolderExists(Server.MapPath(pasta_imagens)) Then

objFS.CreateFolder(Server.MapPath(pasta_imagens))

End if

If Request("enviar") <> "" Then

Set objFS = Nothing

byteCount = Request.TotalBytes

RequestBin = Request.BinaryRead(byteCount)

Dim UploadRequest

Set UploadRequest = CreateObject("Scripting.Dictionary")

BuildUploadRequest RequestBin

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")

If Lcase(Right(filename,3)) = "jpg" Or Lcase(Right(filename,3)) = "gif" then

Set objFS = Server.CreateObject("Scripting.FileSystemObject")

If objFS.FileExists( Server.mappath(pasta_imagens & "\" & filename)) Then

%>

<script language=javascript>

alert("Erro ao enviar imagem, o arquivo '<%=filename%>' já existe na pasta '<%=pasta_imagens%>' do seu site")

enviar.disabled = false;

</script>

<%

Else

If LenB(value) > "200000" then

%>

<script language=javascript>

alert("Erro ao enviar a imagem, o tamanho do arquivo deve ser menor que 200Kb")

enviar.disabled = false;

</script>

<%

Else

%>

<strong>Aguarde o envio da imagem...</strong><br>

<input name="progress" value="0% enviado" style="border:none">

<table width="100" border="0" cellspacing="0" cellpadding="0" style="border: 1px inset">

<tr>

<td><input name="barra" style="border:none; background-color: orangered; height: 10; width:1" readonly=""></td>

<td></td>

</tr>

</table>

<%

Set ScriptObject = Server.CreateObject("Scripting.FileSystemObject")

Set MyFile = ScriptObject.CreateTextFile( Server.mappath(pasta_imagens & "\" & filename))

progress = 0

n = 0

For i = 1 to LenB(value)

MyFile.Write chr(AscB(MidB(value,i,1)))

progress = Fix((i * 100) / LenB(value))

If n <> progress then

n = progress

%>

<script language=javascript>progress.value = "<%=n%>% enviado"</script>

<script language=javascript>barra.style.width = "<%=n%>"</script>

<%

End if

Next

MyFile.Close

' Create instance of AspJpeg

Set Jpeg = Server.CreateObject("Persits.Jpeg")

' Open source image

imagem = ""&replace(Request.ServerVariables("PATH_TRANSLATED"), "admin\upload_foto1.asp", ""&replace(replace(pasta_imagens, "../", ""), "/", "\")&"") &"\" & filename &""

Jpeg.Open imagem

' New width

L = 185

' Resize, preserve aspect ratio

If jpeg.OriginalWidth > jpeg.OriginalHeight Then

jpeg.Width = L

jpeg.Height = jpeg.OriginalHeight * L / jpeg.OriginalWidth

Else

jpeg.Height = L

jpeg.Width = jpeg.OriginalWidth * L / jpeg.OriginalHeight

End If

' create thumbnail and save it to disk

imagem = ""&replace(replace(Request.ServerVariables("PATH_TRANSLATED"), "admin\upload_foto1.asp", ""&replace(replace(pasta_imagens, "../", ""), "/", "\")&""), "grande", "media") &"\" & filename &""

Jpeg.Save imagem

jpeg.close

set jpeg = nothing

Set Jpeg = Server.CreateObject("Persits.Jpeg")

' Open source image

imagem = ""&replace(Request.ServerVariables("PATH_TRANSLATED"), "admin\upload_foto1.asp", ""&replace(replace(pasta_imagens, "../", ""), "/", "\")&"") &"\" & filename &""

Jpeg.Open imagem

' New width

L = 75

' Resize, preserve aspect ratio

If jpeg.OriginalWidth > jpeg.OriginalHeight Then

jpeg.Width = L

jpeg.Height = jpeg.OriginalHeight * L / jpeg.OriginalWidth

Else

jpeg.Height = L

jpeg.Width = jpeg.OriginalWidth * L / jpeg.OriginalHeight

End If

' create thumbnail and save it to disk

imagem = ""&replace(replace(Request.ServerVariables("PATH_TRANSLATED"), "admin\upload_foto1.asp", ""&replace(replace(pasta_imagens, "../", ""), "/", "\")&""), "grande", "pequena") &"\" & filename &""

Jpeg.Save imagem

jpeg.close

set jpeg = nothing

Set Jpeg = Server.CreateObject("Persits.Jpeg")

' Open source image

imagem = ""&replace(Request.ServerVariables("PATH_TRANSLATED"), "admin\upload_foto1.asp", ""&replace(replace(pasta_imagens, "../", ""), "/", "\")&"") &"\" & filename &""

Jpeg.Open imagem

' New width

L = 600

' Resize, preserve aspect ratio

If jpeg.OriginalWidth > jpeg.OriginalHeight Then

jpeg.Width = L

jpeg.Height = jpeg.OriginalHeight * L / jpeg.OriginalWidth

Else

jpeg.Height = L

jpeg.Width = jpeg.OriginalWidth * L / jpeg.OriginalHeight

End If

' create thumbnail and save it to disk

imagem = ""&replace(Request.ServerVariables("PATH_TRANSLATED"), "admin\upload_foto1.asp", ""&replace(replace(pasta_imagens, "../", ""), "/", "\")&"") &"\" & filename &""

Jpeg.Save imagem

jpeg.close

set jpeg = nothing

%>

<script language=javascript>

envia_imagem('<%=pasta_imagens&"" & "/" & filename%>');

</script>

<%

End If

Set objFS = Nothing

End if

Else

%>

<script language=javascript>

alert("Erro ao enviar a imagem, lembre-se que ela deve possuir extensão JPG ou GIF");

enviar.disabled = false;

</script>

<%

End If

End If

%>

<FORM METHOD="post" ENCTYPE="multipart/form-data" ACTION="<%=Request.ServerVariables("SCRIPT_NAME")%>?campo=<%=campo%>&pasta=<%=pasta%>&enviar=sim" onSubmit="enviar.disabled=true">

Enviar uma nova imagem<BR>

<INPUT type="file" name="blob" class="campos_formulario" style="width: 100%"><BR>

<INPUT type="submit" name="enviar" value="Enviar" class="botao_enviar"><br>

<i>(A imagem deve ter nó máximo 200Kb)</i>

</FORM>

Selecionar uma imagem enviada anteriormente<BR>

<DIV class="titulo_campos" style="width:100%; height:175px; visibility: visible; overflow: auto; border:1px solid">

<%

lista_imagens pasta_imagens, "gif,jpg"

Function lista_imagens( strFolder, tipo )

If Trim( Request.QueryString("folder") ) <> "" Then

strFolder = Request.ServerVariables("APPL_PHYSICAL_PATH") & Request.QueryString("folder")

End If

Dim Folder, File

Dim ObjFS, objRootFolder

Set ObjFS = Server.CreateObject("Scripting.FileSystemObject")

Set objFolder = ObjFS.GetFolder(Server.MapPath(strFolder))

For Each File in objFolder.files

tipo = Replace(tipo, ",", "")

For i = 1 to len(tipo) step 3

If Right(File, 3) = Mid(tipo, i, 3) Then

Response.Write "  <a href=""javascript: envia_imagem('"&pasta_imagens&"/" & File.Name & "')"" class=""texto_pagina"">" & File.Name & "</a><BR>" & vbcrlf

End If

Next

Next

Response.Write "</td></tr></table>" & vbcrlf

Set objFolder = Nothing

Set Folder = Nothing

End Function

%>

 

[RonaldoEler 0]

Não sei se é o mesmo que aconteceu comigo, pois uso um upload sem componentes. O fato é que a Microsoft lançou a atualizar do VBscript com um problema (acho que o patch já saiu), e encontrei as informações seguintes:

 

https://support.microsoft.com/en-us/kb/3125446

https://support.microsoft.com/pt-pt/kb/3125446

http://stackoverflow.com/questions/34181411/uploading-a-file-in-classic-asp

http://stackoverflow.com/questions/12190305/how-to-upload-files-with-asp-classic/12200970#12200970

http://windows.microsoft.com/en-us/windows/remove-update#1TC=windows-7

http://stackoverflow.com/questions/34199663/windows-update-breaks-multipart-form-data-update-kb3104002

Pra resolver, utilizei uma das funções que encontrei

Function InstrBNew(startPos, inputArray, searchChar)

  if LenB(searchChar) = 1 Then
    Dim loc
    For loc = startPos to Lenb(inputArray)
      if MidB(inputArray, loc, 1) = searchChar then Exit For
    Next
    InstrBNew = loc
  Else
    InstrBNew = InstrB(startPos, inputArray, searchChar)
  End If
End Function

Substitua tudo que for InstrB por InstrB e dará certo (se for o mesmo erro).

 

Espero ter ajudado.

[renercarvalho 0]

Não sei se é o mesmo que aconteceu comigo, pois uso um upload sem componentes. O fato é que a Microsoft lançou a atualizar do VBscript com um problema (acho que o patch já saiu), e encontrei as informações seguintes:

 

https://support.microsoft.com/en-us/kb/3125446

https://support.microsoft.com/pt-pt/kb/3125446

http://stackoverflow.com/questions/34181411/uploading-a-file-in-classic-asp

http://stackoverflow.com/questions/12190305/how-to-upload-files-with-asp-classic/12200970#12200970

http://windows.microsoft.com/en-us/windows/remove-update#1TC=windows-7

http://stackoverflow.com/questions/34199663/windows-update-breaks-multipart-form-data-update-kb3104002

Pra resolver, utilizei uma das funções que encontrei

Function InstrBNew(startPos, inputArray, searchChar)

  if LenB(searchChar) = 1 Then
    Dim loc
    For loc = startPos to Lenb(inputArray)
      if MidB(inputArray, loc, 1) = searchChar then Exit For
    Next
    InstrBNew = loc
  Else
    InstrBNew = InstrB(startPos, inputArray, searchChar)
  End If
End Function

Substitua tudo que for InstrB por InstrB e dará certo (se for o mesmo erro).

 

Espero ter ajudado.

Ok, amigo. Obrigado! Chegando em casa vou implementar e informo aqui.

[renercarvalho 0]

Não sei se é o mesmo que aconteceu comigo, pois uso um upload sem componentes. O fato é que a Microsoft lançou a atualizar do VBscript com um problema (acho que o patch já saiu), e encontrei as informações seguintes:

 

https://support.microsoft.com/en-us/kb/3125446

https://support.microsoft.com/pt-pt/kb/3125446

http://stackoverflow.com/questions/34181411/uploading-a-file-in-classic-asp

http://stackoverflow.com/questions/12190305/how-to-upload-files-with-asp-classic/12200970#12200970

http://windows.microsoft.com/en-us/windows/remove-update#1TC=windows-7

http://stackoverflow.com/questions/34199663/windows-update-breaks-multipart-form-data-update-kb3104002

Pra resolver, utilizei uma das funções que encontrei

Function InstrBNew(startPos, inputArray, searchChar)

  if LenB(searchChar) = 1 Then
    Dim loc
    For loc = startPos to Lenb(inputArray)
      if MidB(inputArray, loc, 1) = searchChar then Exit For
    Next
    InstrBNew = loc
  Else
    InstrBNew = InstrB(startPos, inputArray, searchChar)
  End If
End Function

Substitua tudo que for InstrB por InstrB e dará certo (se for o mesmo erro).

 

Espero ter ajudado.

Olá, amigo. Dei uma olhada no material que você informou. Tenho um problema, estou com windows 10 e não tem o patch para ele. Olhando nas atualizações, ela não está instalada aqui. Ou seja, no caso das atualizações, não posso fazer nada por aqui. (Tenho um servidor de teste rodando em casa e uso o do starhost para hospedar. Entrei em contato com eles solicitando executarem os procedimentos para resolver o problema no servidor de lá).

Então adicionei a função aqui e fiz as alterações no código, porém ao rodar, deu novo erro:

Erro de tempo de execução do Microsoft VBScript erro '800a01c2'

Número de argumentos incorreto ou atribuição de propriedade inválida:

'InstrBNew'

/admin/upload_foto1.asp, linha 90

Segue a linha 90:

Do until (boundaryPos=InstrBNew(RequestBin,boundary & getByteString("--")))

O que pode ser?

Estou procurando uma saída aqui. Caso encontre, informo também.