返回列表 上一主題 發帖

[發問] 由網頁取得的資料,不知道要如何同步編碼成正確之中文碼回傳

[發問] 由網頁取得的資料,不知道要如何同步編碼成正確之中文碼回傳

[版主管理留言]
  • GBKEE(2016/6/15 12:57): 可Google "亂碼" 尋求解決

本帖最後由 c_c_lai 於 2016-6-15 15:21 編輯

請問各位大大,
由網頁取得的資料,不知道要如何同步編碼成正確之中文碼回傳,
如附圖  (上圖) :

正確應為 (下圖) :
  1. Sub 上市當沖4()
  2.     Dim xTable As Object, k As Integer, c As Integer, R As Integer        '  , sn As Integer
  3.     Dim url As String, cts As Integer, E As Variant, xDate As String      '  , rc As Integer
  4.     Dim oXmlhttp As Object, oHtmldoc As Object, select2 As String         '  , tm
  5.     Dim TVal() As Variant, sPost As String
  6.    
  7.     If Select_Name = -1 Then Exit Sub
  8.     TVal = Array("MS", "", "0049", "0099P", "019919T", "0999", "0999P", "01", "02", "03", _
  9.                 "04", "05", "06", "07", "21", "22", "08", "09", "10", _
  10.                 "11", "12", "13", "24", "25", "26", "27", "28", "29", _
  11.                 "30", "31", "14", "15", "16", "17", "18", "23", "9299", "19", "20", "CB")
  12.    
  13.     url = "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php"
  14.     xDate = Format(Sheets("總表").[B1], "EE/MM/DD")
  15.     sPost = "input_date=" & Replace(xDate, "/", "%2F") & "&select2=" & TVal(Select_Name)  'urlencode
  16.    
  17.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  18.     Set oHtmldoc = CreateObject("htmlfile")
  19.    
  20.     With Sheets("上市")
  21.         .Select
  22.         .Cells.Clear
  23.         
  24.         With oXmlhttp
  25.             .Open "Post", url, False
  26.             '  .setRequestHeader "Connection", "Keep-Alive"   '  短時間內多次查詢建議可加這行
  27.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  28.             .setRequestHeader "Content-Length", Len(sPost)
  29.             .Send sPost
  30.             '  上面 Open 參數用 False (=同步),可以不用再判斷 status
  31.             '  Do While .Status <> 200 Or .readyState <> 4: DoEvents: Loop
  32.             oHtmldoc.write .responseText
  33.             '  MsgBox .responseText
  34.         End With
  35.         
  36.         Set xTable = oHtmldoc.all.tags("TABLE")
  37.         '  Stop
  38.         For Each E In Array(8, 10)       '  8, 10  ->  "TABLE"
  39.             Set xTable = oHtmldoc.all.tags("TABLE")(E)
  40.             '  Set xTable = oHtmldoc.all.tags("TABLE")(0)
  41.             k = k + 1
  42.             
  43.             For R = 0 To xTable.Rows.Length - 1
  44.                 For c = 0 To xTable.Rows(R).Cells.Length - 1
  45.                     Sheets("上市").Cells(k, c + 1) = xTable.Rows(R).Cells(c).INNERTEXT
  46.                 Next
  47.                 k = k + 1
  48.             Next
  49.             If Right(sPost, 3) <> "t2=" Then Exit For
  50.         Next
  51.     End With
  52. End Sub
複製代碼
  1. Private Function Select_Name() As Integer
  2.     With Sheets("總表").ComboBox1
  3.         If .ListIndex = -1 Then MsgBox ("您尚未選擇「產業類別」,請於" & vbCrLf & "確認後再次點選『開啟網頁』," & vbCrLf & "謝謝您!")
  4.         Select_Name = .ListIndex    '  Select_Name = -1,0,1,2,3,4,5,6,7,8,9,.....39
  5.     End With
  6. End Function
複製代碼
謝謝各位大大!

回復 9# yoyobuy
請仔細看一下 #7 圖片裡的下註,便會明瞭了。

TOP

回復 6# joey0415

請問這個用你的 BinToStr( ) 為何就無法轉成功呢

    Sub Test()
        Dim xTable As Object, k As Integer, C As Integer, R As Integer        '  , sn As Integer
        Dim url As String, cts As Integer, E As Variant, xDate As String      '  , rc As Integer
        Dim oXmlhttp As Object, oHtmldoc As Object, select2 As String         '  , tm

        xDate = "105/06/13"
        url = "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php"
        sPost = "input_date=" & Replace(xDate, "/", "%2F") & "&select2=" & "01"  'urlencode
        
        Set oXmlhttp = CreateObject("msxml2.xmlhttp")
        Set oHtmldoc = CreateObject("htmlfile")
        With oXmlhttp
        
        
            .Open "Post", url, False
           '.setRequestHeader "Connection", "Keep-Alive"   '短時間內多次查詢建議可加這行
            .setRequestHeader "Content-Type", "text/html"
            .setRequestHeader "Content-Length", Len(sPost)
            
            .Send sPost
            oHtmldoc.Write .responseText
        End With

        Set xTable = oHtmldoc.ALL.tags("TABLE")
        ' Stop
        '  看看區域變數視窗 xTable 的內容
        Set xTable = oHtmldoc.ALL.tags("TABLE")(0)
        ' Stop
        '  再次看看區域變數視窗 xTable 的內容
        
        'MsgBox xTable.INNERTEXT
        'Debug.Print xTable.INNERTEXT
          gg = BinToStr(xTable.INNERTEXT, "BIG5")
        
        Debug.Print gg
    End Sub



Function BinToStr(arrBin, strChrs)
   Set objstream = CreateObject("ADODB.Stream")
    With objstream
        .Type = 2
        .Open
        .WriteText arrBin
        .Position = 0
        .Charset = strChrs
        .Position = 2
         BinToStr = .ReadText
        .Close
    End With
End Function

TOP

回復 7# c_c_lai

賴大以前幫助小弟很多,小弟只把以前抄的東西修改一下讓賴大試試

TOP

本帖最後由 c_c_lai 於 2016-6-16 11:44 編輯

回復 6# joey0415
回復 4# stillfish00
非常感謝兩位大大的不吝指導,終告完成了。
真是臨門一竅,不點不醒。joey0415 大大提供的範例
以及增加了 Function BinToStr(arrBin, strChrs) 的函式
它扮演了一個非常重要的腳色,受教了!

TOP

回復 5# c_c_lai

賴大試試,我只會拿以前的來改

  1. Sub 證交所()
  2.    
  3.   Dim strText As String
  4.   Dim i As Integer
  5.   Dim j As Integer
  6.   Dim nRow As Integer
  7.   Dim xRow As Integer
  8.   Dim nCol As Byte
  9.   Dim TR As Object
  10.   Dim TD As Object
  11.   Dim Arr()
  12.   Cells.Clear
  13.   
  14.   With CreateObject("winhttp.winhttprequest.5.1")
  15.     .Open "POST", "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php", False
  16.     .setrequestheader "Referer", "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php"
  17.     .setrequestheader "Content-Type", "application/x-www-form-urlencoded"
  18.     .Send "input_date=105%2F06%2F15&select2=21&login_btn=+%ACd%B8%DF+"
  19.     strText = BinToStr(.ResponseBody, "BIG5") '要注意網頁編碼
  20.   End With
  21.   
  22.   With CreateObject("htmlfile")
  23.     .Write strText
  24.             Set hTable = .all.tags("table")(8)
  25.             tt = hTable.Rows.Length
  26.                 With ActiveSheet
  27.                     For i = 0 To hTable.Rows.Length - 1
  28.                         For j = 0 To hTable.Rows(i).Cells.Length - 1
  29.                                 .Cells(i + 1, j + 1) = hTable.Rows(i).Cells(j).innertext
  30.                         Next
  31.                     Next
  32.                 End With
  33.    
  34.   End With
  35. End Sub
  36. Function BinToStr(arrBin, strChrs)
  37.     With CreateObject("ADODB.Stream")
  38.         .Type = 2
  39.         .Open
  40.         .Writetext arrBin
  41.         .Position = 0
  42.         .Charset = strChrs
  43.         .Position = 2
  44.         BinToStr = .ReadText
  45.         .Close
  46.     End With
  47. End Function
複製代碼

TOP

回復 4# stillfish00
不好意思,試了一會還是沒有掌握到
ADODB.Stream 用法心得 , 能否就以我的
test2.rar 為題解惑呢?
謝謝你囉!

TOP

回復 3# c_c_lai
可查查 ADODB.Stream 用法 ,
二進位方式寫入 .responseBody , 再指定字符集以 "big5" 讀出來
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

加入可正常會之程式模組,供作比對:
test2.rar (24.21 KB)

TOP

本帖最後由 c_c_lai 於 2016-6-15 15:22 編輯

對不起,大概我沒描述清楚。樓上的圖片均是透過同樣的網址 ,
而以不同連結處理方式執行出來的結果。
  1.     With ActiveSheet.QueryTables.Add(Connection:= _
  2.                   "URL;http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php", Destination:=Range( _
  3.                   "$A$1"))
複製代碼
連結處理方式 (下圖) 則是正常;但是以
  1.         With oXmlhttp
  2.             .Open "Post", url, False
  3.             '  .setRequestHeader "Connection", "Keep-Alive"   '  短時間內多次查詢建議可加這行
  4.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  5.             .setRequestHeader "Content-Length", Len(sPost)
  6.             .Send sPost
  7.             '  上面 Open 參數用 False (=同步),可以不用再判斷 status
  8.             '  Do While .Status <> 200 Or .readyState <> 4: DoEvents: Loop
  9.             oHtmldoc.write .responseText
  10.             '  MsgBox .responseText
  11.         End With
複製代碼
(上圖) 卻是亂碼。
附上檔案堤供各位大大測試即知,謝謝囉!
test.rar (40.26 KB)

TOP

        靜思自在 : 道德是提昇自我的明燈,不該是呵斥別人的鞭子。
返回列表 上一主題