Public Function CopyScreenToBMP(ByVal szfile As String) As Boolean
Dim w As Long, h As Long
Dim scrDC As Long
Dim DIB As Long, m_DC As Long
Dim BmpInfo As BITMAPINFOHEADER
Dim BmpFileHead As BITMAPFILEHEADER
Dim pData As Long
Dim buff() As Byte
Dim old As Long
Dim L As Long
\'取屏幕 高宽
w = Screen.Width \\ 15
h = Screen.Height \\ 15
\'准备内存DC
m_DC = CreateCompatibleDC(0&)
If m_DC = 0 Then
CopyScreenToBMP = False
Exit Function
End If
\'填充DIB的BMP结构
With BmpInfo
.biBitCount = 24
.biPlanes = 1
.biHeight = h
.biWidth = w
.biSize = 40 \'本结构长度
End With
DIB = CreateDIBSection(m_DC, BmpInfo, DIB_RGB_COLORS, pData, 0, 0)
If DIB = 0 Then
DeleteDC m_DC
CopyScreenToBMP = False
Exit Function
End If
old = SelectObject(m_DC, DIB)
\'拷屏
scrDC = GetDC(0)
BitBlt m_DC, 0, 0, w, h, scrDC, 0, 0, SRCCOPY
\'补足4的倍数
L = (w * 3 + 3) And &H7FFFFFFC
L = L * h
\'分配内存
ReDim buff(1 To L) As Byte
\'取像素数据
CopyMemory VarPtr(buff(1)), pData, L
\'释放资源
SelectObject m_DC, old
DeleteObject DIB
DeleteDC m_DC
ReleaseDC 0, scrDC
\'填充BMPFILE
With BmpFileHead
\'BM标志
.bfType(0) = 66: .bfType(1) = 77
.bfSize = 54 + L \'本文件大小
.bfOffBits = 54 \'像素数据偏移地址
End With
\'写入文件
\'懒得声明变量，直接用 L 存放文件号
L = FreeFile()
Open szfile For Binary As L
\'写入文件头
Put L, 1, BmpFileHead
Put L, , BmpInfo
\'写入实际像素
Put L, , buff()
Close L
CopyScreenToBMP = True
End Function
\'
\'例程
Option Explicit
Private Sub cmdTest_Click()
Dim OK As Boolean
OK = CopyScreenToBMP(\"c:\\test.bmp\")
If OK Then
Set Me.Picture = LoadPicture(\"c:\\test.bmp\")
Else
MsgBox \"CAO,拷屏失败了~\"
End If
End Sub
责任编辑：小草
