Solução do problema de acentos do XMLHTTP da Microsoft

Você precisa estar logado para dar um feedback. Clique aqui para efetuar o login
Para efetuar o download você precisa estar logado. Clique aqui para efetuar o login
Confirmar voto
0
 (4)  (0)

Veja neste artigo a solução do problema de acentos do XMLHTTP da Microsoft


Extraído do site: http://www.codigofonte.com.br

Já faz algum tempo que percebi que o componente para requisição HTTP da Microsoft conhecido como XMLHTTP tem um sério

problema na leitura de páginas que contenham acentos.

Como não encontrei nenhuma solução no site da Microsoft, desenvolvi a minha própria e que funciona perfeitamente.

A solução consiste na utilização de uma função que converte os dados em formato Binário para String (chamada

BinaryToString), desta forma ao resgatar o conteúdo de uma URL é preciso trazê-lo somente em formato binário e depois

convertê-lo. Desta forma não ocorre mais os problemas de acentuação.

<%  
'------------------------------------------------  
Public Function BinaryToString(xBinary)  
    Dim Binary  
    Dim RS, LBinary  
    If VarType(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary  
    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  
        BinaryToString = RS("mBinary")  
    Else 
        BinaryToString = "" 
    End If 
    Set RS = Nothing 
End Function 
 
Public Function MultiByteToBinary(MultiByte)  
    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 
    Set RS = Nothing 
    MultiByteToBinary = Binary  
End Function 
'------------------------------------------------  
 
 
'Declaração das variáveis  
Dim objXmlHttp  
Dim Url  
Dim Conteudo  
 
'Inicialização do objeto  
Set objXmlHttp  = Server.CreateObject("MSXML2.XMLHTTP")  
       
'Url do Site  
Url = "
http://rss.terra.com.br/0,,EI4795,00.xml
                  
'Resgatando os dados da URL via HTTP  
objXMLHttp.Open "GET", Url, False 
objXMLHttp.Send  
 
'Utilizando a função "BinaryToString" não haverá mais problemas com acentos.  
Conteudo = BinaryToString(objXmlHttp.ResponseBody)  
 
Response.ContentType = "text/xml" 
Response.Write Conteudo  
 
'Destruição do objeto  
Set objXmlHttp  = Server.CreateObject("MSXML2.XMLHTTP")  
%> 
<%
'------------------------------------------------
Public Function BinaryToString(xBinary)
 Dim Binary
 Dim RS, LBinary
 If VarType(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
 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
  BinaryToString = RS("mBinary")
 Else
     BinaryToString = ""
 End If
 Set RS = Nothing
End Function

Public Function MultiByteToBinary(MultiByte)
 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
 Set RS = Nothing
 MultiByteToBinary = Binary
End Function
'------------------------------------------------


'Declaração das variáveis
Dim objXmlHttp
Dim Url
Dim Conteudo

'Inicialização do objeto
Set objXmlHttp = Server.CreateObject("MSXML2.XMLHTTP")
 
'Url do Site
Url = "
http://rss.terra.com.br/0,,EI4795,00.xml"
         
'Resgatando os dados da URL via HTTP
objXMLHttp.Open "GET", Url, False
objXMLHttp.Send

'Utilizando a função "BinaryToString" não haverá mais problemas com acentos.
Conteudo = BinaryToString(objXmlHttp.ResponseBody)

Response.ContentType = "text/xml"
Response.Write Conteudo

'Destruição do objeto
Set objXmlHttp = Server.CreateObject("MSXML2.XMLHTTP")
%>

 
Você precisa estar logado para dar um feedback. Clique aqui para efetuar o login
Receba nossas novidades
Ficou com alguma dúvida?