標題: 下載網頁內容出現錯誤 在此內容中不允操作 [打印本頁]

---

作者: tsunamix03    時間: 2016-10-13 21:23     標題: 下載網頁內容出現錯誤 在此內容中不允操作

Private Sub CommandButton1_Click()

Dim starttime As Variant
Dim fountrow As Integer, col As Integer, topic As Integer, row As Integer

starttime = Now()

'Application.ScreenUpdating = False ' 關閉螢幕更新，加快速度。

    Set XML = CreateObject("Microsoft.XMLHTTP")
    Set Stream = CreateObject("ADODB.stream")
    Dim path As String, thePOSTdata, URL
    Dim stockID()
    col = 0
    row = 1
    topic = 0
    stockID = Array(2605, 2606, 2607, 2608)
    URL = "http://www.twse.com.tw/ch/trading/exchange/STOCK_DAY/STOCK_DAYMAIN.php"
    For x = 0 To UBound(stockID)
        For y = 2014 To 2016
            For z = 1 To 12
                If xlYear = 2016 And xlMonth = 11 Then       '超過目前日期則跳出迴圈
                    Exit For
                End If
                thePOSTdata = "download=csv&query_year=" & y & "&query_month=" & z & "&CO_ID=" & stockID(x)
                XML.Open "POST", URL, 0
                XML.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                XML.send thePOSTdata
        
                With Stream
               
                    .Type = 1
                    .Mode = 3
                    .Open
                    .Write XML.responseBody
                    .Position = 0
                    .Type = 2
                    .Charset = "Big5"
                    ByteToText = .ReadText
                    'MsgBox ByteToText

                    Dim arr() As String
   
                    arr = Split(ByteToText, Chr(10))       'Chr(10)代表Enter鍵嗎???
   
                    Dim processstring As String
   
                    For i = 0 To UBound(arr)
                        'MsgBox arr(i)
                        processstring = Replace(arr(i), """,""", "^^")
   
                        'putdata = Split(arr(i), "^^")
                        putdata = Split(processstring, "^^")
                        'If Not (topic = 1 And i = 0) Then
         
                            For j = 0 To UBound(putdata)
                                'Sheets(i).Cells(65536, col).End(xlUp).Offset(1, 0)
                                Sheets(2).Cells(row, j + 1 + col).NumberFormatLocal = "@"
                                '工作表1.Cells(i + 1, j + 1).Value = CStr(Replace(Replace(putdata(j), """", ""), "=", ""))
                                'MsgBox putdata(j)
                                ShowString = Replace(Trim(putdata(j)), ",", "")
                                ShowString = Replace(ShowString, """", "")
                                ShowString = Replace(ShowString, "=", "")
                                Sheets(2).Cells(row, j + 1 + col).Value = ShowString
                                'If j = 1 Then
                                '    topic = 1
                                'End If
                                
            
                            Next j
                            row = row + 1
                        'End If
                        
                    Next i

                End With
        
   
            Next
        Next
        col = col + 10
        row = 1
        topic = 0
    Next
   
End Sub

Type = 1被標記成黃色，請問高手到底哪裡出錯

---

作者: tsunamix03    時間: 2016-10-13 21:41

已解決   謝謝大家

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)