Sub 簡易明細下載()
Dim 股票代號 As String, 日期 As Variant, N, i As Integer, A, T As Date
Do While Not IsDate(日期)
日期 = InputBox("輸入查詢日期", "日期", Date)
If 日期 = "" Then End
Loop
Do While 股票代號 = ""
股票代號 = InputBox("股票代號", "輸入查詢之股票代號", "1101")
If 日期 = "" Then End
Loop
日期 = Format(日期, "yyyymmdd")
T = Time
With ActiveSheet
For Each N In .Names
N.Delete
Next
.Cells.Clear
Application.StatusBar = False
On Error GoTo A_Wait
i = 1
Do
.Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
With .QueryTables.Add(Connection:="URL;http://bsr.twse.com.tw/bshtm/bshtm_report_Messages.aspx?strDate=" & 日期 & "&StartNumber=" & 股票代號 & "&FocusIndex=" & i, Destination:=Selection)
.Name = 日期 & "_" & 股票代號 & "_" & i
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
''''''無法查詢時稍待 到 A_Wait: '''''
.Refresh BackgroundQuery:=False
If Application.CountA(.ResultRange) = 0 Then GoTo Out
i = i + 1
End With
A = CreateObject("WScript.Shell").popup("請等後下載..." & Chr(10) & Chr(10) & "** 請勿按下 [確定] **", 4, 日期 & "_" & 股票代號 & " 第" & i & "頁", 16 * 3 + 0)
Application.ScreenUpdating = True
Loop
Out:
.UsedRange.Columns.AutoFit
.[A1].Select
A = CreateObject("WScript.Shell").popup("共下載" & i & "頁", 5, 日期 & "_" & 股票代號, 48 + 0)
Application.StatusBar = 股票代號 & " 共下載 " & i & "頁 費時 " & Format(Time - T, "HH:MM:SS")
End With
End
A_Wait:
Application.StatusBar = "無法查詢等候5秒鐘"
Application.Wait Now + TimeValue("00:00:05")
Err.Clear
Application.StatusBar = False
Resume '重返查詢
End Sub作者: HSIEN6001 時間: 2012-4-19 23:14
Dim MSXML As Object
Set MSXML = CreateObject("Microsoft.XMLHTTP")
fh = FreeFile
'strWebsite = "http://bsr.twse.com.tw/bshtm/bshtm_report_Messages.aspx?strDate=20140227&StartNumber=2330"
strWebsite = "http://bsr.twse.com.tw/bshtm/bsMenu.aspx?HiddenField_page=PAGE_BS&HiddenField_spDate=&__EVENTTARGET=&__EVENTARGUMENT=&__VIEWSTATE=%2FwEPDwUKLTQzNzI3ODE3MQ9kFgICAQ9kFhQCBQ8WAh4JaW5uZXJodG1sBQoyMDE0LzAyLzI3ZAIGDxYCHwAFCDIwMTQwMjI3ZAIIDw8WBh4JRm9udF9Cb2xkZx4EXyFTQgKEEB4JRm9yZUNvbG9yCj1kZAIKD2QWBAIBDw9kFgIeB09uQ2xpY2sFHGphdmFzY3JpcHQ6YnV0Q2xlYXJfQ2xpY2soKTtkAgcPFgIeBXN0eWxlBQlkaXNwbGF5OjsWAmYPZBYCZg9kFgICAQ8WAh8ABQIxM2QCDA8PFgYfAWgfAgKEEB8DCkdkZAIODw8WAh4HVmlzaWJsZWhkZAIQDw8WBh8BaB8CAoQQHwMKR2RkAhIPFgIfAGVkAhQPFgIfAGVkAhUPFgIfAAUCMTNkZJhG1J6ISYtK7kIpEfImJdIAAAAA&__EVENTVALIDATION=%2FwEWCQLryNa%2BCwLjpuXcAwKN4Ij0CwLB5ZfoCQLjk6TKBwKY8en5CwLdkpmPAQL6n7vzCwLAhrvLBScjE4xZjzHjsp%2FT1DwVl9MAAAAA&HiddenField_spDate=20140227&HiddenField_page=PAGE_BS&txtTASKNO=2330&hidTASKNO=2330&btnOK=%E6%9F%A5%E8%A9%A2"
MSXML.Open "POST", strWebsite, False
strWebsite = "http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=2330&FocusIndex=All_13"
MSXML.Open "GET", strWebsite, False
MSXML.SetRequestHeader "Content-type", "text/xml"
MSXML.send
strpageContent = MSXML.responseText
' Save html as text/xml
Open "C:\myStock\AccessVBA-2330.txt" For Output As #FreeFile
Print #fh, strpageContent
Set MSXML = Nothing
Close #fh
