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

Option Explicit
Sub 證交所_買賣交易日報表()
Dim Stock_NO As String, Sh As Worksheet, URL As String, WB As Workbook
Do
Stock_NO = InputBox("股票號碼")
If Stock_NO = "" Then Exit Sub
Loop Until Len(Stock_NO) >= 4
Set Sh = ActiveWorkbook.Sheets.Add
Application.DisplayAlerts = False
On Error GoTo Er
Sh.Name = Stock_NO
Application.StatusBar = "下載資料中.... "
Application.ScreenUpdating = False
URL = "http://bsr.twse.com.tw/bshtm/bsContent.aspx?StartNumber=" & Stock_NO & "&FocusIndex=All_" & 報表頁數(Stock_NO)
Set WB = Workbooks.Open(URL)
With WB.Sheets(1)
If .UsedRange.Count = 1 Then GoTo xOUT '股票沒有資料
.UsedRange.Columns("A:Q").ClearFormats
.UsedRange.Columns("B:H").Delete Shift:=xlToLeft
.UsedRange.Columns("B:B").SpecialCells(xlCellTypeBlanks).Offset(, -1).Delete xlShiftUp
.UsedRange.Columns("B:E").SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
.UsedRange.Columns("F:J").SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
.UsedRange.Columns("F:J").Cut .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
.Rows("1:2").Delete
With .UsedRange
.Value = .Value
.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes
.Offset(3).Replace "序", "=XXX", xlWhole
.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
End With
.UsedRange.Copy Sh.[A1]
Sh.UsedRange.EntireColumn.AutoFit
End With
WB.Close False
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
Er:
Sheets(Stock_NO).Delete
Resume
xOUT:
WB.Close False
Sheets(Stock_NO).Delete
MsgBox "沒有股票 " & Stock_NO
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Function 報表頁數(Sstock_N0 As String) As String
Dim element As Object
With CreateObject("InternetExplorer.Application")
.Navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
Do While .Busy Or .ReadyState <> 4
DoEvents
Loop
.Document.getElementsByName("txtTASKNO")(0).Value = Sstock_N0
.Document.getElementsByName("btnOK")(0).Click
Do While .Busy Or .ReadyState <> 4
DoEvents
Loop
報表頁數 = .Document.getElementsByName("sp_ListCount")(0).innertext
.Quit
End With
End Function

複製代碼

Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'剪貼版資料格式定義
Private Const CF_DIB = 8
Sub 驗證碼識別()
Dim a(1 To 4)
Dim img '（驗證碼）圖片
Dim CtrlRange '非文本物件集合
Dim bytClipData() As Byte '定義位元組陣列
Dim arr(0 To 1260)
Dim ts As Integer
On Error Resume Next
Set Regedit_XG = CreateObject("WScript.Shell") '創建一個空的VBS"殼"
Jz = Regedit_XG.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\1407") '讀取註冊表"安全設置-Internet區域"中的"允許對剪貼板進行編程訪問"設置(3＝禁用、0＝啟用、1＝提示)原始值
Regedit_XG.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\1407", "0", "REG_DWORD" '修改註冊表"安全設置-Internet區域"中的"允許對剪貼板進行編程訪問"設置(3＝禁用、0＝啟用、1＝提示)，使系統默認為"允許訪問剪貼板"
With CreateObject("InternetExplorer.application") '創建一個空的ie
.Visible = True '讓ie可見
.Navigate "http://119.145.135.38/fscx/web/loginForm.do" '導航到http://119.145.135.38/fscx/web/loginForm.do
Do Until .ReadyState = 4 '等待ie完畢載入
DoEvents
Loop
Set img = .Document.All.tags("img")(0) '指定（驗證碼）目標圖片
Set CtrlRange = .Document.body.createControlRange() '創建非文本物件 ControlRange 集合
CtrlRange.Add img '向非文本物件 ControlRange 集合中添加 img 物件
CtrlRange.execCommand "Copy", True '從 ControlRange 集合中copy img 物件（圖片）到剪貼板
Dim hMem As Long, lpData As Long
OpenClipboard 0& '打開粘貼板
hMem = GetClipboardData(8) '獲得粘貼板資料，指定格式為：CF_DIB = 8
If CBool(hMem) Then
lpData = GlobalLock(hMem) '鎖定記憶體物件hMen
lClipSize = GlobalSize(hMem) '獲得粘貼板資料位元組數
If lpData <> 0 And lClipSize > 0 Then
ReDim bytClipData(0 To lClipSize - 1) As Byte '重新定義位元組陣列大小
CopyMemory bytClipData(0), ByVal lpData, lClipSize '粘貼板轉化成位元組陣列
End If
GlobalUnlock hMem '解除鎖定記憶體物件hMen
End If
CloseClipboard '關閉粘貼板
For i = 1 To 1260 '歸一化處理
ts = (Val(bytClipData((i - 1) * 3 + 40)) + Val(bytClipData((i - 1) * 3 + 41)) + Val(bytClipData((i - 1) * 3 + 42))) / 3 '40是圖片開始位元組
If ts > 150 Then
ts = 0
Else
ts = 1
End If
arr(i) = ts
Next i
For i = 1 To 4
a(i) = 0 '0
If arr(13 * 60 + 8 + (i - 1) * 14) = 1 And arr(14 * 60 + 8 + (i - 1) * 14) = 1 Then a(i) = 1: GoTo 1 '16位色，所以乘以"3"RGB各占一位元組，60是寬，14是字間距，
If arr(4 * 60 + 6 + (i - 1) * 14) = 1 Then a(i) = 2: GoTo 1 '2
If arr(16 * 60 + 11 + (i - 1) * 14) = 0 Then a(i) = 3: GoTo 1 '3
If arr(7 * 60 + 5 + (i - 1) * 14) = 1 Then a(i) = 4: GoTo 1 '4
If arr(12 * 60 + 9 + (i - 1) * 14) = 1 Then a(i) = 5: GoTo 1 '5
If arr(9 * 60 + 8 + (i - 1) * 14) = 1 And arr(11 * 60 + 9 + (i - 1) * 14) = 1 Then a(i) = 6: GoTo 1 '6
If arr(16 * 60 + 13 + (i - 1) * 14) = 1 Then a(i) = 7: GoTo 1 '7
If arr(10 * 60 + 8 + (i - 1) * 14) = 1 And arr(11 * 60 + 8 + (i - 1) * 14) = 1 Then a(i) = 8: GoTo 1 '8
If arr(9 * 60 + 9 + (i - 1) * 14) = 1 Then a(i) = 9 '9
1:
Next i
Cells(1, 1) = a(1) & a(2) & a(3) & a(4) '識別後的驗證碼
.Document.All.tags("INPUT")(0).Value = "1234567890" '填寫登錄名
.Document.All.tags("INPUT")(1).Value = "0987654321" '填寫密碼
.Document.All.tags("INPUT")(2).Value = Cells(1, 1) '填寫驗證碼
.Document.All.tags("img")(1).Click '點擊"登錄"按鈕
'.Quit '關閉ie
'MsgBox "OK"
End With
Regedit_XG.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3\1407", Jz, "REG_DWORD" '恢復註冊表"安全設置-Internet區域"中的"允許對剪貼板進行編程訪問"設置(3＝禁用、0＝啟用、1＝提示)原始值
Set Regedit_XG = Nothing '釋放VBS"殼"
End Sub

複製代碼