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

renercarvalho · Janeiro 7, 2016

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

Function getString(StringBin)

getString =""

For intCount = 1 to LenB(StringBin)

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

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

%>

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

%>

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>

<tr>

</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

%>

<%

End if

' 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

%>

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

</script>

<%

End If

Set objFS = Nothing

End if

Else

%>

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

enviar.disabled = false;

</script>

<%

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>

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

</FORM>

Selecionar uma imagem enviada anteriormente<BR>

<%

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

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

Set objFolder = Nothing

Set Folder = Nothing

End Function

%>

RonaldoEler · Janeiro 7, 2016

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 · Janeiro 7, 2016

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 · Janeiro 8, 2016

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.

Entrar

Arquivado

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

Recommended Posts

renercarvalho 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

RonaldoEler 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

renercarvalho 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

renercarvalho 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

Conexão mysql com outro domínio

[Resolvido] JavaScript - Exibir logo dentro da Tabela html

Javascript - Calcular Valores Monetário em Tempo Real

Este projeto é apoiado pelas empresas

Fóruns

Tempo Real

Informação importante