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
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Const CF_TEXT = 1
Public Const CF_BITMAP = 2
Public Const CF_DIB = 8
Sub 驗證圖()
Dim img
Dim CtrlRange
Dim bytClipData() As Byte
Dim arr() As String
Dim ts As Integer
Cells.Clear
Cells.Font.Size = 4
Cells.RowHeight = 6
Cells.ColumnWidth = 0.6
Cells.Font.Bold = True
On Error Resume Next
With CreateObject("InternetExplorer.application")
.Visible = True
.Navigate "http://bsr.twse.com.tw/bshtm/bsMenu.aspx"
Do Until .ReadyState = 4
DoEvents
Loop
Set img = .Document.all.tags("img")(1)
Set CtrlRange = .Document.body.createControlRange()
CtrlRange.Add img
CtrlRange.execCommand "Copy", True
Dim hMem As Long, lpData As Long
OpenClipboard 0&
hMem = GetClipboardData(8)
If CBool(hMem) Then
lpData = GlobalLock(hMem)
lClipSize = GlobalSize(hMem)
If lpData <> 0 And lClipSize > 0 Then
ReDim bytClipData(0 To lClipSize - 1)
CopyMemory bytClipData(0), ByVal lpData, lClipSize
End If
GlobalUnlock hMem
End If
CloseClipboard
' For i = 0 To UBound(bytClipData)
' Cells(i + 1, 1) = bytClipData(i)
' Next i
'Erase arr()
a1 = bytClipData(0)
a2 = bytClipData(4)
a3 = bytClipData(8)
a4 = lClipSize - a1
a5 = a4 / a2 / a3
If a5 < 3 Then
a1 = lClipSize - a2 * a3
a5 = 1
Else
a5 = Int(a5)
End If
ReDim arr(1 To a2 * a3)
For i = 1 To a2 * a3
arr(i) = ""
ts = 0
'For j = 0 To a5 - 1
' ts = ts + Val(bytClipData((i - 1) * a5 + a1 + 2))
'Next j
'ts = ts / a5
ts = Val(bytClipData((i - 1) * a5 + a1 + 2))
If ts > 220 Then
arr(i) = 1
End If
'If i / a2 = Int(i / a2) Then a1 = a1 + 0
Next i
For i = 2 To a3 - 1
For j = 2 To a2
Cells(a3 + 1 - i, j) = arr((i - 1) * a2 + j)
Next j
Next i
For i = 2 To a3
For j = 2 To a2
p = 0
For m = -1 To 1
For n = -1 To 1
p = p + Cells(i + m, j + n)
Next n
Next m
If p < 3 Then Cells(i, j) = "" '第一次去雜信
Next j
Next i
For i = 3 To a3
For j = 3 To a2
p = 0
For m = -2 To 2
For n = -2 To 2
p = p + Cells(i + m, j + n)
Next n
Next m
If p < 4 Then Cells(i, j) = "" '第二次去雜信
Next j
Next i
' temp = ""
' For i = 2 To a2
' For j = 2 To a3 - 1
' Cells(a3 + 1, i) = Cells(a3 + 1, i) + Cells(j, i)
' Next j
' If Cells(a3 + 1, i) = 0 Then Cells(a3 + 1, i) = ""
' Next i
' .Quit
End With
