麻辣家族討論版版 - Powered by Discuz! Board

Sub 上市當沖4()
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
Dim TVal() As Variant, sPost As String
If Select_Name = -1 Then Exit Sub
TVal = Array("MS", "", "0049", "0099P", "019919T", "0999", "0999P", "01", "02", "03", _
"04", "05", "06", "07", "21", "22", "08", "09", "10", _
"11", "12", "13", "24", "25", "26", "27", "28", "29", _
"30", "31", "14", "15", "16", "17", "18", "23", "9299", "19", "20", "CB")
url = "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php"
xDate = Format(Sheets("總表").[B1], "EE/MM/DD")
sPost = "input_date=" & Replace(xDate, "/", "%2F") & "&select2=" & TVal(Select_Name) 'urlencode
Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Set oHtmldoc = CreateObject("htmlfile")
With Sheets("上市")
.Select
.Cells.Clear
With oXmlhttp
.Open "Post", url, False
' .setRequestHeader "Connection", "Keep-Alive" ' 短時間內多次查詢建議可加這行
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Content-Length", Len(sPost)
.Send sPost
' 上面 Open 參數用 False (=同步)，可以不用再判斷 status
' Do While .Status <> 200 Or .readyState <> 4: DoEvents: Loop
oHtmldoc.write .responseText
' MsgBox .responseText
End With
Set xTable = oHtmldoc.all.tags("TABLE")
' Stop
For Each E In Array(8, 10) ' 8, 10 -> "TABLE"
Set xTable = oHtmldoc.all.tags("TABLE")(E)
' Set xTable = oHtmldoc.all.tags("TABLE")(0)
k = k + 1
For R = 0 To xTable.Rows.Length - 1
For c = 0 To xTable.Rows(R).Cells.Length - 1
Sheets("上市").Cells(k, c + 1) = xTable.Rows(R).Cells(c).INNERTEXT
Next
k = k + 1
Next
If Right(sPost, 3) <> "t2=" Then Exit For
Next
End With
End Sub

複製代碼

Private Function Select_Name() As Integer
With Sheets("總表").ComboBox1
If .ListIndex = -1 Then MsgBox ("您尚未選擇「產業類別」，請於" & vbCrLf & "確認後再次點選『開啟網頁』，" & vbCrLf & "謝謝您！")
Select_Name = .ListIndex ' Select_Name = -1,0,1,2,3,4,5,6,7,8,9,.....39
End With
End Function

複製代碼

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php", Destination:=Range( _
"$A$1"))

複製代碼

With oXmlhttp
.Open "Post", url, False
' .setRequestHeader "Connection", "Keep-Alive" ' 短時間內多次查詢建議可加這行
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Content-Length", Len(sPost)
.Send sPost
' 上面 Open 參數用 False (=同步)，可以不用再判斷 status
' Do While .Status <> 200 Or .readyState <> 4: DoEvents: Loop
oHtmldoc.write .responseText
' MsgBox .responseText
End With

複製代碼

Sub 證交所()
Dim strText As String
Dim i As Integer
Dim j As Integer
Dim nRow As Integer
Dim xRow As Integer
Dim nCol As Byte
Dim TR As Object
Dim TD As Object
Dim Arr()
Cells.Clear
With CreateObject("winhttp.winhttprequest.5.1")
.Open "POST", "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php", False
.setrequestheader "Referer", "http://www.twse.com.tw/ch/trading/exchange/TWTB4U/TWTB4U.php"
.setrequestheader "Content-Type", "application/x-www-form-urlencoded"
.Send "input_date=105%2F06%2F15&select2=21&login_btn=+%ACd%B8%DF+"
strText = BinToStr(.ResponseBody, "BIG5") '要注意網頁編碼
End With
With CreateObject("htmlfile")
.Write strText
Set hTable = .all.tags("table")(8)
tt = hTable.Rows.Length
With ActiveSheet
For i = 0 To hTable.Rows.Length - 1
For j = 0 To hTable.Rows(i).Cells.Length - 1
.Cells(i + 1, j + 1) = hTable.Rows(i).Cells(j).innertext
Next
Next
End With
End With
End Sub
Function BinToStr(arrBin, strChrs)
With CreateObject("ADODB.Stream")
.Type = 2
.Open
.Writetext arrBin
.Position = 0
.Charset = strChrs
.Position = 2
BinToStr = .ReadText
.Close
End With
End Function

複製代碼