vb adodb.stream write写入网页代码为utf8编码的问题

Question

从网页通过inet控件的Inet1.GetChunk读取其代码，然后想转换为汉字，转换代码如下
Private Sub Inet1_StateChanged(ByVal State As Integer)
    Dim strRecText As String
    Dim strBuffer As String
    Select Case State
        Case 1
            StatusBar1.Panels(2) = "正在查询主机的IP"
        Case 2
            StatusBar1.Panels(2) = "成功找到主机的IP"
        Case 3
            StatusBar1.Panels(2) = "正在于主机链接"
        Case 4
            StatusBar1.Panels(2) = "与主机链接成功"
        Case 5
            StatusBar1.Panels(2) = "正在向主机传送命令"
        Case 6
            StatusBar1.Panels(2) = "成功向主机传送命令"
        Case 7
            StatusBar1.Panels(2) = "正在接收主机的响应"
        Case 8
            StatusBar1.Panels(2) = "成功接收主机的响应"
        Case 11
            StatusBar1.Panels(2) = "超时"
        Case 12
            Do
                strBuffer = Inet1.GetChunk(10240)
                strRecText = strRecText & strBuffer
            Loop Until Len(strBuffer) = 0
            'Print #3, strRecText
            '此次开始调用转换函数（utf8编码转为汉字）
            str = BytesToBstr(StrRecData, "utf-8")
            ’处理转换后的代码
            Call WrRecToHFLex(str)
        Case Else
            StatusBar1.Panels(2) = "其他情况！！"
    End Select
End Sub’转换函数Function BytesToBstr(strBody, CodeBase)
        Dim objStream        
        Set objStream = CreateObject("Adodb.Stream")
        objStream.Type = 1
        objStream.Mode = 3
        objStream.Open
        'objStream.LoadFromFile strBody
        If Len(strBody) <> 0 Then objStream.Write (strBody)
        objStream.Position = 0
        objStream.Type = 2
        objStream.Charset = CodeBase
        BytesToBstr = objStream.ReadText
        objStream.Close
        Set objStream = Nothing
End Function运行后出现实时错误：“实时错误'3001': 参数类型不正确，或不在可接受范围之内，或与其他参数冲突。”，按调试，就是红色字哪里出错（If Len(strBody) <> 0 Then objStream.Write (strBody)）这里出错，请各位高手指点一下，错在哪里，我查了网上很多资料，很多都出现了这个错误，但没有被根本解决；我也尝试把这段代码改为：If Len(strBody) <> 0 Then objStream.WriteText (strBody)但出现错误为“实时错误'3219':在此环境中不允许操作；小弟刚入行，不懂这些这么高深的用法，请路过大侠帮帮我啊，在此谢过，并在线等

Answer 1

        If Len(strBody) <> 0 Then objStream.Write (strBody) 
        objStream.Position = 0 
        objStream.Type = 2 
        objStream.Charset = CodeBase 没写过这样的程序，感觉你这里的顺序代码顺序可能存在顺序问题。
--Function ReadTextFile (FilePath,CharSet)
dim str,stm
set stm=server.CreateObject("adodb.stream")
stm.Type=2 '以文本模式读取
stm.mode=3 
stm.charset=CharSet
stm.open
stm.loadfromfile FilePath
str=stm.readtext
stm.Close
set stm=nothing
ReadTextFile=str
End functionSub WriteTextFile (FilePath,Str,CharSet)
dim stm 
set stm=server.CreateObject("adodb.stream")
stm.Type=2 '以文本模式读取
stm.mode=3
stm.charset=CharSet
stm.open
stm.WriteText str
stm.SaveToFile FilePath,2 
stm.flush
stm.Close
set stm=nothing
End Sub去网上看了下，你的代码顺序是有问题。

Answer 2

To 2L:兄断章取义了，“If Len(strBody) <> 0 Then objStream.Write (strBody)”上面还有对objStream属性的设置呢

Answer 3

1、objStream.Write要求的参数是个数组，你传个String参数当然会提示你参数类型不正确。
2、objStream.Type=1和objStream.Write配合使用，objStream.Type = 2和objStream.WriteText配合使用，你光把objStream.Write改成objStream.WriteText但没修改objStream.Type当然还是要报错

Answer 4

Option ExplicitPrivate Sub Command1_Click()
    Call Inet1.Execute("http://localhost/newjygl/public/login.aspx")
End SubFunction BytesToBstr(ByRef strBody As String, ByVal CodeBase As String)
        strBody = StrConv(strBody, vbFromUnicode)
        
        Dim objStream As New ADODB.Stream        objStream.Type = adTypeText
        objStream.Mode = adModeReadWrite
        objStream.Open        If Len(strBody) <> 0 Then
            objStream.WriteText strBody
        End If        objStream.Position = 0
        objStream.Type = adTypeText
        objStream.Charset = CodeBase        BytesToBstr = objStream.ReadText        objStream.Close
        Set objStream = Nothing
End FunctionPrivate Sub Inet1_StateChanged(ByVal State As Integer)
    Select Case State
    Case 12
        Dim strBuffer As String
        Dim strRecText As String
        Do
            strBuffer = Inet1.GetChunk(10240)
            strRecText = strRecText & strBuffer
        Loop Until Len(strBuffer) = 0
                        
        strRecText = BytesToBstr(strRecText, "utf-8")
    End Select
End Sub剩下的自己改改把。

Answer 5

Option ExplicitPrivate Sub Command1_Click()
    Call Inet1.Execute("http://localhost/newjygl/public/login.aspx")
End SubFunction BytesToBstr(ByVal strBody As String, ByVal CodeBase As String)
        strBody = StrConv(strBody, vbFromUnicode)
        
        Dim objStream As New ADODB.Stream        objStream.Type = adTypeText
        objStream.Mode = adModeReadWrite
        objStream.Open        If Len(strBody) <> 0 Then
            objStream.WriteText strBody
        End If        objStream.Position = 0
        objStream.Type = adTypeText
        objStream.Charset = CodeBase        BytesToBstr = objStream.ReadText        objStream.Close
        Set objStream = Nothing
End FunctionPrivate Sub Inet1_StateChanged(ByVal State As Integer)
    Select Case State
    Case 12
        Dim strBuffer As String
        Dim strRecText As String
        Do
            strBuffer = Inet1.GetChunk(10240)
            strRecText = strRecText & strBuffer
        Loop Until Len(strBuffer) = 0
                        
        strRecText = BytesToBstr(strRecText, "utf-8")
    End Select
End Sub

Answer 6

To 7楼的高手CityBird 您好，按照您所说的我更改了，没有报错了能转换成功，但转换后有一部分没有转换，显示像“？”问号这样的乱码？而大部分都被正确转换了，请问是什么原因啊？谢谢

Answer 7

通讯的问题，以字符流方式通讯的时候每个字节的取值范围为0-127，不是0-255,所以采用这种方式通讯的时候如果出现超过127的字节数据，接收方实际收到的数据就有问题，你现在碰到的就是这种问题。
Function GetChunk(Size As Long, [DataType])
这个是Inet的GetChunk方法的定义，第二个[DataType]参数有两个值icByteArray和icString，默认是icString，要解决这个问题把第二个参数改成icByteArray就可以了。

Answer 8

Option ExplicitPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Sub Command1_Click()
    Inet1.Execute "http://ask.koubei.com/question/1306083100901.html"
End SubFunction BytesToBstr(ByRef arrBody() As Byte, ByVal CodeBase As String) As String
    '无数据
    If UBound(arrBody) = 0 Then
        BytesToBstr = ""
        Exit Function
    End If
    
    Dim objStream As New ADODB.Stream    objStream.Type = adTypeBinary
    objStream.Mode = adModeReadWrite
    objStream.Open
    
    objStream.Write arrBody    objStream.Position = 0
    objStream.Type = adTypeText
    objStream.Charset = CodeBase
    
    BytesToBstr = objStream.ReadText
    objStream.Close
    Set objStream = Nothing
End FunctionPrivate Sub Inet1_StateChanged(ByVal State As Integer)
    Select Case State
    Case 12
        Dim arrBuffer() As Byte         '累计接收的数据
        Dim tmpBuffer() As Byte         '单次GetChunk获得的数据
        Dim recCount As Long            '累计接收的字节数
        Dim strRecText As String
        
        tmpBuffer = Inet1.GetChunk(1024, icByteArray)
        recCount = UBound(tmpBuffer)
        
        Do
            ReDim Preserve arrBuffer(recCount + UBound(tmpBuffer))
            CopyMemory arrBuffer(recCount), tmpBuffer(0), UBound(tmpBuffer)
            recCount = recCount + UBound(tmpBuffer)
            
            tmpBuffer = Inet1.GetChunk(1024, icByteArray)
        Loop Until UBound(tmpBuffer) < 0
        
        strRecText = BytesToBstr(arrBuffer, "utf-8")
    End Select
End Sub参考这个改改吧，希望Yahoo的同志不要找我麻烦，我拿它们的网站做测试

Answer 9

上面那个有点问题，前面有1024个ASCII码为0的字符，用下面这个
Option ExplicitPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Sub Command1_Click()
    Inet1.Execute "http://ask.koubei.com/question/1306083100901.html"
End SubFunction BytesToBstr(ByRef arrBody() As Byte, ByVal CodeBase As String) As String
    '无数据
    If UBound(arrBody) = 0 Then
        BytesToBstr = ""
        Exit Function
    End If
    
    Dim objStream As New ADODB.Stream    objStream.Type = adTypeBinary
    objStream.Mode = adModeReadWrite
    objStream.Open
    
    objStream.Write arrBody    objStream.Position = 0
    objStream.Type = adTypeText
    objStream.Charset = CodeBase
    
    BytesToBstr = objStream.ReadText
    objStream.Close
    Set objStream = Nothing
End FunctionPrivate Sub Inet1_StateChanged(ByVal State As Integer)
    Select Case State
    Case 12
        Dim arrBuffer() As Byte         '累计接收的数据
        Dim tmpBuffer() As Byte         '单次GetChunk获得的数据
        Dim recCount As Long            '累计接收的字节数
        Dim strRecText As String
        
        recCount = 0
        tmpBuffer = Inet1.GetChunk(1024, icByteArray)
        
        Do
            ReDim Preserve arrBuffer(recCount + UBound(tmpBuffer))
            CopyMemory arrBuffer(recCount), tmpBuffer(0), UBound(tmpBuffer)
            recCount = recCount + UBound(tmpBuffer)
            
            tmpBuffer = Inet1.GetChunk(1024, icByteArray)
        Loop Until UBound(tmpBuffer) < 0
        
        strRecText = BytesToBstr(arrBuffer, "utf-8")
    End Select
End Sub

Answer 10

CityBird 您好，不好意思，这两天出差了，今天回来按照您提供的代码和思路已经把问题解决了，非常谢谢您，我结贴时会另给您加50分，我是个菜鸟，希望高手您日后多多指点哦。在结贴前有问题想请教一下您：您是怎么想到要用Api CopyMemory来写数组啊？能把您的思路告知我吗？因为如果是我的话，根本就不会想到这里，谢谢您！

Answer 11

处理什么速度更快的方法，下载网页、UTF-8编码转换还是数组处理？10秒钟主要花在什么地方了，什么地方是瓶颈？

Answer 12

谢谢您 CityBird ：你一说就提醒了我，之前我只是记录了总时长，你一说后我把各处理过程的时长都记录了，我下载一个网页大小为7k左右，数组处理用了1～2秒，UTF-8编码转换用了0～1秒，正则表达式处理时长最长用了6秒，服务器延时：1秒；我觉得应该要优化一下正则表达式处理的代码，不知道您有没有更好的方法来优化呢？还有就是请问如果想得到下载网页的长度，用什么较好的方法来获取呢？这个是额外加的，希望您别介意，我先把贴给结了。谢谢您的指点

Answer 13

CityBird在吗？今天测试了后又出现乱码了？请问什么问题啊？乱码：&#36808;&#38463;&#23494;&#28909;&#28779;    帖子已经结了，麻烦您帮我在解决一下，谢谢

Answer 14

这个不是乱码，CHRW(36808)就得出对应的汉字了。

Answer 15

你可以尝试用Inet.GetHeader("Content_Length")取得网页的大小，但是这个不一定都能取到！

Answer 16

这个是在取下来的网页里面哦，这样是不是还要每一个都拿出来，然后通过CHRW(36808)来转换，如果这样会很慢的，有没有更快的方法啊，因为一个网页读下来后的代码，不一定就只有这几个

Answer 17

如果要一个个的来判断，然后是这样的编码时用chrw（）的话，速度也很慢，同时也要判断是否是中文

Answer 18

CityBird  请问没有更好的办法吗？