worldy大侠希望能再请教您之前的问题，非常感谢！！
--------------------编程问答-------------------- Private Function GetWindowBmp(hwnd As Long, _BmpInfo As BITMAPINFO, _
nBits As Long, _
Optional mOffset As Long = 0) As Byte()
Dim hDCx As Long
Dim hBmp As Long
Dim R As Long
Dim hMemDC As Long
Dim nWidth As Long, nHeight As Long
Dim RECT As RECT
Dim ImgData() As Byte
Dim mLine As Long
Dim mLineBytes As Long 'Dim ImgData() As Byte'Dim mLineBytes As Long
Call GetWindowRect(hwnd, RECT)
nWidth = RECT.Right - RECT.Left 'MsgBox nWidth '1280
nHeight = RECT.Bottom - RECT.Top 'MsgBox nHeight '1024
hDCx = GetDC(hwnd)
hMemDC = CreateCompatibleDC(hDCx)
hBmp = CreateCompatibleBitmap(hDCx, nWidth, nHeight)
'R = SelectObject(hMemDC, hBmp)
'R = BitBlt(hMemDC, 0, 0, nWidth, nHeight, hDCx, 0, 0, 13369376)
SelectObject hMemDC, hBmp '这句的作用是什么？为什么下面又赋值了r
将上面创建的兼容位图选入到内存dc（hMemDC),它会返回原来已经存在的位图句柄，由于不需要再使用返回值，因此，可以不赋值给r，你要赋值给r也可以，但是没有什么用
BitBlt hMemDC, 0, 0, nWidth, nHeight, hDCx, 0, 0, 13369376 '13369376是什么意思？
BitBlt 拷贝模式，vbSrcCopy，就是一对一拷贝，其它的拷贝模式可以参阅BitBlt 函数
With BmpInfo.bmiHeader
.biSize = Len(BmpInfo.bmiHeader)
.biWidth = nWidth
.biHeight = -nHeight
.biPlanes = 1
.biBitCount = nBits
.biCompression = BI_RGB
End With
mLineBytes = (((nWidth * nBits) + &H1F) And &HFFFFFFE0) \ &H8 '&H1F，&H8，&HFFFFFFE0是什么意思呢
上整个计算为宽度字节进行整定，以使每行字节数都是4的倍数
ReDim ImgData(mLineBytes * nHeight - 1 + mOffset) 'MsgBox mLineBytes * nHeight - 1 + mOffset & "--"
mLine = GetDIBits(hDCx, hBmp, 0, nHeight, ImgData(mOffset), BmpInfo, BI_RGB)
这个函数将位图数据拷贝到ImgData数组中，拷贝位置从mOffset开始,mOffset之前的字节你可以作为别的用途，比如保存bmp文件时，可以填充bmp文件的头数据
GetWindowBmp = ImgData
DeleteDC hMemDC
ReleaseDC hwnd, hDCx
DeleteObject hBmp
End Function
Sub GCTTTTT()
这个函数的hdc应该原来笔误，hdc应该定义为hwnd更直观
Dim T1 As Single, T2 As Single, T3 As Single, TTTX1 As Single, TTTX2 As Single
T1 = Timer
'----------------------------------
Dim ImgData() As Byte
Dim mLineBytes As Long
Dim BITMAPINFO As BITMAPINFO
Dim mLineBytesA As Long
Dim mIdx As Long
'Dim X As Long, Y As Long, C As Long
Dim mLineFromIdx As Long
Dim mBytesPerPix As Long
Dim hdc As Long
hdc = GetDesktopWindow()
ImgData = GetWindowBmp(hdc, BITMAPINFO, 32&) '获取Pic1窗口上显示的位图数据 */*/32&是什么意思？
32是你获取的位图数据每像素的颜色位数，32就是1个像素是4字节，如果是24，则每像素为3字节
'到此，获得整个桌面窗口的位图数据到ImgData数组
'-----------------------------------
End Sub --------------------编程问答--------------------
非常感谢回答啊，不好意思又麻烦您啦！
不好意思我C的基础差哦，希望请教您：
1.去掉call fuction直接写成一个sub应该怎么写呢？不好意思这个问题比较画蛇添足啊~~
2.修改为获取三维数组的Imgdata应该怎么写呢？三维数组更好用哦 ^^
3. “mLine = GetDIBits(hDCx, hBmp, 0, nHeight, ImgData(mOffset), BmpInfo, BI_RGB)
这个函数将位图数据拷贝到ImgData数组中，拷贝位置从mOffset开始,mOffset之前的字节你可以作为别的用途，比如保存bmp文件时，可以填充bmp文件的头数据
GetWindowBmp = ImgData”
请问这个返回值mLine是什么用途的呢，我以为可以去掉但是去掉了会出错了哦；另外这个赋值GetWindowBmp = ImgData请问是什么意思呢，GetWindowBmp这个名字和fuction的名字是一样哦~ --------------------编程问答-------------------- 1.去掉call fuction直接写成一个sub应该怎么写呢？不好意思这个问题比较画蛇添足啊~~
把call 和后面的参数的挎号一起去掉即可（VB的基础，该补补课啊）
2.修改为获取三维数组的Imgdata应该怎么写呢？三维数组更好用哦 ^^
这个不好改，别老想着美女的三围
3. “mLine = GetDIBits(hDCx, hBmp, 0, nHeight, ImgData(mOffset), BmpInfo, BI_RGB)
这个函数将位图数据拷贝到ImgData数组中，拷贝位置从mOffset开始,mOffset之前的字节你可以作为别的用途，比如保存bmp文件时，可以填充bmp文件的头数据
GetWindowBmp = ImgData”
请问这个返回值mLine是什么用途的呢，我以为可以去掉但是去掉了会出错了哦；另外这个赋值
返回位图的行数
GetWindowBmp = ImgData请问是什么意思呢，GetWindowBmp这个名字和fuction的名字是一样哦~
让函数返回包含了位图数据的数组（VB的基础，该补补课啊）
--------------------编程问答--------------------
worldy您好，第一个问题我其实是想请教如何写成只有声明和一个sub的代码，我尝试把function的代码放进sub里但是失败了呢~~
就是将现在的：
1.声明
2.fuction
3.sub
写成
1.声明
2.sub
这样的形式 ：）
第二个问题，女生的三围男生的最爱啊 ^^
请教您如何修改为三维数组，希望能指导下啊，下面贴一段三维数组的VB找图代码：
'============================================
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'============================================
Option Explicit
Dim mousestep As POINTAPI
Dim moubegin As POINTAPI
'获得当前光标的坐标。
'GetCursorPos moubegin
' mousestep = moubegin
'鼠标移到 SetCursorPos moubegin.X, moubegin.Y
'====================================================
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 SetDIBits Lib "gdi32" (ByVal HDC 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 Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
'左键单击
'====================================================
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '获取句柄
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long '获取图片数据
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal HDC As Long) As Long '释放DC
Private Declare Function CreateCompatibleDC 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 Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal HDC As Long, ByVal hObject As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Dim intX As Long
Dim intY As Long
'颜色表
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte '透明通道
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 BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
'图片文件头
Dim BI As BITMAPINFO
Dim BI1 As BITMAPINFO
Dim PP As New Form1
'在图片1中查找图片2，是否找出全部
Public Function FindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, fileurl As String)
Dim P2 As Picture, P2W, P2H, P2Handle
Set P2 = LoadPicture("F:\1.bmp")
P2W = P2.Width
P2H = P2.Height
P2Handle = P2.Handle
Dim W As Long, H As Long, I As Long, J As Long
Dim W1 As Long, H1 As Long, I1 As Long, J1 As Long
Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long
Dim zPic() As Byte, fPic() As Byte
Dim R As Byte, G As Byte, B As Byte
'1 获得图片2数据
W2 = ScaleX(P2W, vbHimetric, vbPixels)
H2 = ScaleY(P2H, 8, 3)
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = W2
.biHeight = -H2
.biBitCount = 32
.biPlanes = 1
End With
ReDim zPic(3, W2 - 1, H2 - 1)
I = GetDIBits(HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
Set P2 = Nothing
'Debug.Print I
'如果在这里处理一下，图像大的话，可能会快一点。
'2 获得图片1数据
W = Right
H = Bottom
For J2 = 0 To H2 - 2 '循环判断小图片
For I2 = 0 To W2 - 2
PP.PSet (I2, J2), RGB(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))
Next I2
Next J2
PP.Refresh
Dim P1 As Picture, P1W, P1H, P1Handle
Set P1 = LoadPicture("F:\2.bmp")
P1W = P1.Width
P1H = P1.Height
P1Handle = P1.Handle
W1 = ScaleX(P1W, vbHimetric, vbPixels)
H1 = ScaleY(P1H, 8, 3)
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W1
.biHeight = -H1
.biBitCount = 32
.biPlanes = 1
End With
ReDim fPic(3, W1 - 1, H1 - 1)
I = GetDIBits(HDC, P1Handle, 0, H1, fPic(0, 0, 0), BI1, 0)
Set P1 = Nothing
'Debug.Print I
'分析查找
For J = 0 To H - H2 - 1
VBA.DoEvents
For I = 0 To W - W2 - 1
For J2 = 0 To H2 - 2 '循环判断小图片
For I2 = 0 To W2 - 2
If fPic(2, I + I2, J + J2) <> zPic(2, I2, J2) Then GoTo ExitLine: 'R
If fPic(1, I + I2, J + J2) <> zPic(1, I2, J2) Then GoTo ExitLine: 'G
If fPic(0, I + I2, J + J2) <> zPic(0, I2, J2) Then GoTo ExitLine: 'B
Next I2
Next J2
'Debug.Print "发现:", I, J
intX = I
intY = J
ExitLine:
Next I
Next J
'获得当前光标的坐标。
'GetCursorPos moubegin
'mousestep = moubegin
'鼠标移到
End Function
Public Function MoveTo(X As Long, Y As Long)
SetCursorPos X, Y
End Function
Private Sub Cmd1_Click()
Dim TimerMsg
Dim sTimer As Single '''定义操作时间 计时变量
sTimer = Timer '''记录遍历图片内容的开始时间
FindPic CLng(Text1.Text), CLng(Text2.Text), CLng(Text3.Text), CLng(Text4.Text), Text5.Text
If intX > 0 And intY > 0 Then
MoveTo intX, intY
mouse_event &H4 Or &H2, 0, 0, 0, 0 '左键单击
TimerMsg = "找到坐标: " & intX & "," & intY
intX = 0
intY = 0
Else
TimerMsg = "沒有找到"
End If
sTimer = Timer - sTimer '''计时结束,并记录用时长度
TimerMsg = TimerMsg & vbCrLf & " 用时: " & sTimer * 1000 & "毫秒" '''显示异点,和耗时
Label2.Caption = TimerMsg
End Sub
--------------------编程问答--------------------
定义函数是为了提高程序可读性
多处使用类似语句时还可减少代码数量
一般来说
将每个功能或步骤定义成一个Fuction或者Sub是最好的
仅仅要修改主楼这段程序非要修改为一体的话
只需要把Fuction改为Sub的
然后在变量定义结束处插入
hwnd = GetDesktopWindow()
并且删除掉
GetWindowBmp = ImgData
及以后的语句就行了
当然了
原先Sub里除
Dim ImgData() As Byte
Dim BITMAPINFO As BITMAPINFO
之外的语句要增加到后面去 --------------------编程问答-------------------- 好像还要插入一句：
nBits = 32&
还有个mOffset得测试一下看需不需要定义
mOffset As Long
--------------------编程问答--------------------
hello 您好 ^^
这样子好像不行哦~~这个传参数的方式我看着一直觉得蛮奇怪的呢~~ --------------------编程问答-------------------- Option Explicit
Private Type BITMAPINFOHEADER '40 bytes
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
End Type
Private Type BitmapInfo
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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 DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hDC 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 WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Const BI_RGB = 0&
Dim hDCx As Long
Dim hBmp As Long
Dim R As Long
Dim hMemDC As Long
Dim nWidth As Long, nHeight As Long
Dim RECT As RECT
Dim ImgData() As Byte
Dim mLine As Long
Dim mLineBytes As Long
'Dim ImgData() As Byte
'Dim mLineBytes As Long
Dim BitmapInfo As BitmapInfo
Dim mLineBytesA As Long
Dim mIdx As Long
Dim x As Long, y As Long, C As Long
Dim mLineFromIdx As Long
Dim mBytesPerPix As Long
Private Type PointData
R As Byte
G As Byte
B As Byte
Reserved As Byte
End Type
Private Function GetWindowBmp(hwnd As Long, _
BmpInfo As BitmapInfo, _
nBits As Long, _
Optional mOffset As Long = 0) As PointData()
Dim hDCx As Long
Dim hBmp As Long
Dim R As Long
Dim hMemDC As Long
Dim nWidth As Long, nHeight As Long
Dim RECT As RECT
Dim ImgData() As PointData
Dim mLine As Long
Dim mLineBytes As Long 'Dim ImgData() As Byte'Dim mLineBytes As Long
Call GetWindowRect(hwnd, RECT)
nWidth = RECT.Right - RECT.Left 'MsgBox nWidth '1280
nHeight = RECT.Bottom - RECT.Top 'MsgBox nHeight '1024
hDCx = GetDC(hwnd)
hMemDC = CreateCompatibleDC(hDCx)
hBmp = CreateCompatibleBitmap(hDCx, nWidth, nHeight)
'R = SelectObject(hMemDC, hBmp)
'R = BitBlt(hMemDC, 0, 0, nWidth, nHeight, hDCx, 0, 0, 13369376)
SelectObject hMemDC, hBmp '这句的作用是什么？为什么下面又赋值了r
BitBlt hMemDC, 0, 0, nWidth, nHeight, hDCx, 0, 0, 13369376 '13369376是什么意思？
With BmpInfo.bmiHeader
.biSize = Len(BmpInfo.bmiHeader)
.biWidth = nWidth
.biHeight = nHeight
.biPlanes = 1
.biBitCount = nBits
.biCompression = BI_RGB
End With
mLineBytes = (((nWidth * nBits) + &H1F) And &HFFFFFFE0) \ &H8 '&H1F，&H8，&HFFFFFFE0是什么意思呢
ReDim ImgData(nWidth - 1, nHeight - 1)
mLine = GetDIBits(hDCx, hBmp, 0, nHeight, ImgData(0, 0), BmpInfo, BI_RGB)
GetWindowBmp = ImgData
DeleteDC hMemDC
ReleaseDC hwnd, hDCx
DeleteObject hBmp
End Function
Sub GetPic()
Dim T1 As Single, T2 As Single, T3 As Single, TTTX1 As Single, TTTX2 As Single
T1 = Timer
'----------------------------------
Dim ImgData() As PointData
Dim mLineBytes As Long
Dim BitmapInfo As BitmapInfo
Dim mLineBytesA As Long
Dim mIdx As Long
'Dim X As Long, Y As Long, C As Long
Dim mLineFromIdx As Long
Dim mBytesPerPix As Long
Dim hDC As Long
hDC = GetDesktopWindow()
ImgData = GetWindowBmp(hDC, BitmapInfo, 32&) '获取Pic1窗口上显示的位图数据 */*/32&是什么意思？
'到此，获得整个桌面窗口的位图数据到ImgData数组
'-----------------------------------
End Sub
Private Sub Picture1_Click()
End Sub
Private Sub Command1_Click()
Dim ImgData() As PointData
Dim mLineBytes As Long
Dim BitmapInfo As BitmapInfo
Dim mLineBytesA As Long
Dim mIdx As Long
Dim x As Long, y As Long, C As Long
Dim mLineFromIdx As Long
Dim mBytesPerPix As Long
ImgData = GetWindowBmp(Pic1.hwnd, BitmapInfo, 32&) '获取Pic1窗口上显示的位图数据
With BitmapInfo.bmiHeader
'计算每行字节数
mLineBytes = .biWidth * .biBitCount / 8
If mLineBytes Mod 4 <> 0 Then
mLineBytesA = ((mLineBytes + 3) \ 4) * 4
Else
mLineBytesA = mLineBytes
End If
mBytesPerPix = .biBitCount / 8 '每像素字节数
For y = 0 To .biHeight - 1
For x = 0 To .biWidth - 1
C = ImgData(x, y).B
C = C + CLng(ImgData(x, y).G) + CLng(ImgData(x, y).R)
C = C \ 3
ImgData(x, y).R = C
ImgData(x, y).G = C
ImgData(x, y).B = C
Next
Next
End With
SetDIBits 0, Pic2.Image, 0, BitmapInfo.bmiHeader.biHeight, ImgData(0, 0), BitmapInfo, BI_RGB
'‘如果Pic2.Image改为Pic1.Image则，将Pic1的彩色改变为黑白
Pic2.Refresh
End Sub --------------------编程问答--------------------
不奇怪
只是要求传入参数的类型而已
补充：VB , API
