使用象棋巫師人機對戰，自動刷QQ天天象棋分
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0
Private Const OBJ_BITMAP As Long = 7
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
'Gray=R*0.3+G*0.59+B*0.11
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private bi24BitInfo As BITMAPINFO
Private aBytes() As Byte
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpclassname As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCurrentObject Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long '取表單大小位置
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function PrintWindow Lib "user32" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long '畫線宣告
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long '釋放DC參照屏
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long '取色宣告
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '宣告發訊息PostMessage
Private Const WM_LBUTTONDOWN = &H201 '按下滑鼠左鍵
Private Const WM_LBUTTONUP = &H202 '釋放滑鼠左鍵
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
'***************以上是API申明部分以及BMP檔案頭定義等*******************
Public Function getcolour(ByVal hwnd As Variant, colour_bgr As Variant, xz As Long, yz As Long, xqc As Long, yqc As Long, xzc As Long, yzc As Long) As Long '后臺截圖，引數1要截圖的視窗句柄，引數2要保存的檔案路徑
'Public Function getcolour(ByVal hWnd As Variant, aBytes As Variant, xz As Long, yz As Long, xqc As Long, yqc As Long, xzc As Long, yzc As Long) As Long '后臺截圖，引數1要截圖的視窗句柄，引數2要保存的檔案路徑
Dim hWndTarget As Long
Dim rc As RECT
Dim rc1 As RECT
Dim iBitmap As Long
Dim mDC As Long, nDC As Long
Dim mBmp As Long
Dim oldBmp As Long
Dim W As Long, h As Long, Bmplen As Long, R As Long, i As Long, ii As Long
Dim BMPbyte(53) As Byte
hWndTarget = hwnd
If hWndTarget = 0 Then
getcolour = 0
Exit Function
End If
GetWindowRect hWndTarget, rc '得到句柄視窗的矩形位置，大小
If (rc.Right - rc.Left) Mod 4 > 0 Then
W = rc.Right - rc.Left - ((rc.Right - rc.Left) Mod 4) + 4
Else
W = rc.Right - rc.Left
End If
h = rc.Bottom - rc.Top
With bi24BitInfo.bmiHeader '初始化24位BMP資訊頭
.biBitCount = 24
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = W
.biHeight = h
.biSizeImage = 3 * W * h
End With
'*************************以下初始化BMP檔案頭資訊到位元組陣列*檔案頭 + 位圖資訊 + 位影像素資料******************
''以上寫位圖資訊******************************************
On Error Resume Next
nDC = GetDC(hWndTarget) '得到指定視窗句柄DC
mDC = CreateCompatibleDC(nDC) '創建記憶體DC
mBmp = CreateCompatibleBitmap(nDC, W, h)
oldBmp = SelectObject(mDC, mBmp) '把視窗位圖選入記憶體DC
PrintWindow hWndTarget, mDC, 0 '把視窗截取保存到記憶體DC中，
ReDim aBytes(0 To W * h * 3 - 1) As Byte
iBitmap = GetCurrentObject(mDC, OBJ_BITMAP) '用于獲得指定型別的當前選定物件
Dim a As Long, x As Long, y As Long, n As Long
a = GetDIBits(mDC, iBitmap, 0, h, aBytes(0), bi24BitInfo, DIB_RGB_COLORS)
'*************》》》》》》》》》》》》》》》》》
'ReDim colour_bgr(0 To W * h * 3 - 1) As Byte
'Dim colour_bgr As Variant
colour_bgr = aBytes
xz = W
yz = h
GetClientRect hwnd, rc1
Dim xy1 As POINTAPI
xy1.x = 0
xy1.y = 0
ClientToScreen hwnd, xy1
xqc = xy1.x - rc.Left
yqc = xy1.y - rc.Top
Dim xy2 As POINTAPI
xy2.x = rc1.Right
xy2.y = rc1.Bottom
ClientToScreen hwnd, xy2
xzc = rc.Right - xy2.x
yzc = rc.Bottom - xy2.y
'*************》》》》》》》》》》》》》》》
DeleteObject iBitmap
DeleteObject mBmp
DeleteObject oldBmp
DeleteDC mDC
DeleteDC nDC
Erase aBytes
' Erase aBytes2
getcolour = 1
End Function
Function 發送表單XY點單擊(hwnd As Long, x As Long, y As Long) '向指定句柄表單XY發送模擬單擊
Dim hwndXY As Long '用于儲存計算后PostMessage所用的坐標
hwndXY = x + y * 65536
Call PostMessage(hwnd, WM_LBUTTONDOWN, 0, hwndXY)
Call PostMessage(hwnd, WM_LBUTTONUP, 0, hwndXY)
End Function
Function 巫師開局1電腦先2我先(ByVal sx As Long)
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, g As Long, h As Long, fs As Long
d = FindWindow("#32770", "象棋巫師")
If d > 0 Then
e = FindWindowEx(d, 0, "Button", "確定")
Call 發送表單XY點單擊(e, 50, 15) '關確定
Call 發送表單XY點單擊(e, 50, 15) '關確定
Sleep 200
End If
If FindWindowEx(FindWindow("ThunderRT6FormDC", "開始對局"), 0, "ThunderRT6CommandButton", "確定") > 0 Then
Call 發送表單XY點單擊(FindWindowEx(FindWindow("ThunderRT6FormDC", "開始對局"), 0, "ThunderRT6CommandButton", "確定"), 5, 5)
Sleep 1000
End If
a = FindWindow("ThunderRT6FormDC", "象棋巫師")
b = FindWindowEx(a, 0, "Toolbar20WndClass", vbNullString)
c = FindWindowEx(b, 0, "msvb_lib_toolbar", vbNullString)
Call 發送表單XY點單擊(c, 5, 5) '開始對局
Sleep 200
a = FindWindow("ThunderRT6FormDC", "開始對局")
b = FindWindowEx(a, 0, "ThunderRT6Frame", "誰先走")
If sx = 2 Then
Call 發送表單XY點單擊(FindWindowEx(b, 0, "ThunderRT6OptionButton", "我先走"), 5, 5)
End If
If sx = 1 Then
Call 發送表單XY點單擊(FindWindowEx(b, 0, "ThunderRT6OptionButton", "電腦先走"), 5, 5)
End If
Sleep 200
Call 發送表單XY點單擊(FindWindowEx(a, 0, "ThunderRT6CommandButton", "確定"), 5, 5)
End Function
Function 指紋對比(s1 As String, s2 As String) As Long '取指定句柄表單圖形指紋
Dim n As Long, n1 As Long
n1 = 0
For n = 1 To 16
If Mid(s1, n, 1) = Mid(s2, n, 1) Then
n1 = n1 + 1
End If
Next n
指紋對比 = n1
End Function
Function 圖形指紋(colour_bgr As Variant, xw As Long, yh As Long, xq As Long, yq As Long, xz As Long, yz As Long) As String '取指定句柄表單圖形指紋
Dim r1 As Long, g1 As Long, b1 As Long, hse1 As Long, hse0 As Long, w_jg As Double, h_jg As Double, yn As Long, xn As Long, y1 As Long, x1 As Long, y As Long, x As Long, y2 As Long, x2 As Long
Dim hase As String, ha As String, ha1 As String, sn As Long, n1 As Long, n2 As Long, n3 As Long, nd As Long, bgr1 As Long, bgr As Long, bgr2 As Long, bgrbgr As Long
Dim i As Long
sn = 64
w_jg = (xz - xq) / 9
h_jg = (yz - yq) / 8
hase = ""
For yn = 1 To 8
ha = ""
For xn = 1 To 9
x1 = xq + Round(w_jg * (xn - 1))
y1 = yq + Round(h_jg * (yn - 1))
x2 = xq + Round(w_jg * xn)
y2 = yq + Round(h_jg * yn)
n1 = 0
bgrbgr = 0
For y = y1 To y2 - 1
For x = x1 To x2 - 1
i = 3 * ((yh - y) * xw + x)
bgr = (colour_bgr(i) \ sn) * sn * 0.11 + (colour_bgr(i + 1) \ sn) * sn * 0.59 + (colour_bgr(i + 2) \ sn) * sn * 0.3
bgrbgr = bgrbgr + (bgr \ sn) * sn
n1 = n1 + 1
Next x
Next y
bgr2 = bgrbgr / n1
If xn > 1 Then
If bgr1 <= bgr2 Then
ha = ha & "1"
Else: ha = ha & "0"
End If
End If
bgr1 = bgr2
Next xn
ha1 = Application.WorksheetFunction.Bin2Hex(ha)
' Sheet1.Cells(24 + yf, 6) = ha1
hase = hase & ha1
Next yn
Sheet1.Cells(23, 6) = hase
圖形指紋 = hase
End Function
Private Sub CommandButton1_Click()
'》》》》》》》》》》》》》》》》》
Dim t As Long, t1 As Long, t2 As Long, t3 As Long, t4 As Long, a1 As Long
Dim nn As Long, n As Long, n1 As Long, n2 As Long, n3 As Long, n4 As Long, zd As Long, zx As Long
t1 = timeGetTime
'》》》》》》》》》》》》》》》》》提示打開象棋
n = 0
openQQWS:
If FindWindow("QQChess", "中國象棋2017") = 0 Or FindWindow("ThunderRT6FormDC", "象棋巫師") = 0 Then
n = n + 1
MsgBox "沒有打開中國象棋或象棋巫師，請打開后再確定，3次提示后將退出程式，第" & n & "次提示"
If n > 2 Then
MsgBox "沒有打開中國象棋或象棋巫師，確定后退出程式"
Exit Sub
End If
GoTo openQQWS
End If
'》》》》》》》》》》》》》》》》》提示打開象棋
'》》》》》》》》》》》》》》》》》定位棋位及點
Dim wsh As Long, qqh As Long
Dim wsrc As RECT, wsx0 As Long, wsy0 As Long, wsjg As Long
Dim qqrc As RECT, qqx0 As Long, qqy0 As Long, qqjg As Long
Dim wsdc As Long
wsh = FindWindow("ThunderRT6FormDC", "象棋巫師") 'x=39,+57,'y=79,+57
qqh = FindWindow("QQChess", "中國象棋2017")
wsdc = GetDC(wsh)
GetClientRect wsh, wsrc
If wsrc.Right = 664 And wsrc.Bottom = 488 Then
wsx0 = 38 '3
wsy0 =
uj5u.com熱心網友回復：
好像沒發全,建議把檔案上傳到百度網盤,點擊共享,然后把共享代碼貼在這里;轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/21760.html
標籤：VBA