الان میخوام کدی رو بگذارم که باهاش میشه اون Bitmap رو توی یک فایل با فرمت .bmp ذخیره کرد.

وقتی قبلا تابع BitBlt رو توضیح میدادم روش عکس گرفتن از صفحه ی نمایش(Screen Shot) رو توی ویبی و با استفاده از فرم گفتم.توی اون روش با این تابع اول محتویات صفحه ی نمایش توی فرم کپی میشد و بلافاصله با تابع داخلی ویبی یعنی SavePicture اون عکس توی فایل ذخیره میشد.حالا میخواییم بدون استفاده از اون فرم و درواقع با Bitmap ی که خودمون توی حافظه درست کردیم اون عکس رو بگیریم و save کنیم.یه قسمت از کد مثل پست قبله با این فرق که دیگه ما اصلا با فرم کاری نداریم و با صفحه ی نمایش کار داریم واسه همین بجای اینکه فرم رو بستر قرار بدیم و از HDC ش برای تابع CreateCompatableDC استفاده کنیم ایندفه با تابع CreateDC یک Device Context درست میکنیم و ازش استفاده میکنیم و آخر سر هم Delete ش میکنیم.برای ساختن یک Device Context از صفحه ی نمایش و گرفتن یک هندل از اون کافیه آرگومان اول تابع(Driver Name) رو “DISPLAY” قرار بدین و بقیه رو نال (Byval 0&) . بعد از اون با BitBlt محتویات رو توی Bitmap ی که ساختیم کپی میکنیم و اون رو توی فایل Save میکنیم

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const BI_bitfields = 3&
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = 2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_BEGIN = 0
Private Const FILE_CURRENT = 1
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

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 BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(256) As RGBQUAD
End Type

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long

Private Sub Form_Load()
Dim retval As Long
retval = ScreenShot
If (retval) Then
MsgBox "Error (" & retval & ")"
Else
MsgBox "Succeed!", vbInformation
End If
Unload Me
End Sub

Private Function ScreenShot()
Dim scrWidth As Long, scrHeight As Long
Dim hScreenDC As Long, hCmpDC As Long, hBmp As Long
scrWidth = Screen.Width / 15
scrHeight = Screen.Height / 15
hScreenDC = CreateDC("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
hCmpDC = CreateCompatibleDC(hScreenDC)
hBmp = CreateCompatibleBitmap(hScreenDC, scrWidth, scrHeight)
Call SelectObject(hCmpDC, hBmp)
BitBlt hCmpDC, 0, 0, scrWidth, scrHeight, hScreenDC, 0, 0, SRCCOPY
Call BitmapToFile(hBmp, hCmpDC, Screen.Height / 15, "d:\mm.bmp")
DeleteObject (hBmp)
DeleteDC (hCmpDC)
DeleteDC (hScreenDC)
End Function

Private Function BitmapToFile(hBmp As Long, hCmpDC As Long, nHeight As Long, FileName As String) As Long
Dim BInfo As BITMAPINFO
BInfo.bmiHeader.biSize = 40
If (GetDIBits(hCmpDC, hBmp, 0, nHeight, ByVal 0&, BInfo, DIB_RGB_COLORS) = 0) Then
BitmapToFile = 1
Exit Function
End If
Dim BBits() As Byte
ReDim BBits(0 To BInfo.bmiHeader.biSizeImage - 1) As Byte
If (GetDIBits(hCmpDC, hBmp, 0, nHeight, BBits(0), BInfo, DIB_RGB_COLORS) = 0) Then
BitmapToFile = 2
Exit Function
End If
Dim BFheader As BITMAPFILEHEADER
BFheader.bfType = 19778
BFheader.bfReserved1 = 0
BFheader.bfReserved2 = 0
Dim hFile As Long: Dim SA As SECURITY_ATTRIBUTES
hFile = CreateFile(FileName, GENERIC_WRITE, 0, SA, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If (hFile = -1) Then
BitmapToFile = 3
Exit Function
End If
Dim bWritten As Long
WriteFile hFile, BFheader, Len(BFheader), bWritten, ByVal 0&
WriteFile hFile, BInfo.bmiHeader, 40, bWritten, ByVal 0&
Dim nPalette As Long
If (BInfo.bmiHeader.biClrUsed) Then
nPalette = lbinfo.bmiHeader.biClrUsed
Else
If (BInfo.bmiHeader.biCompression = BI_bitfields) Then
nPalette = 3
Else
nPalette = IIf(BInfo.bmiHeader.biBitCount <= 8, 2 ^ BInfo.bmiHeader.biBitCount, 0)
End If
End If
If (nPalette) Then
WriteFile hFile, BInfo.bmiColors(0), nPalette * 4, bWritten, ByVal 0&
End If
BFheader.bfOffBits = SetFilePointer(hFile, 0, 0, FILE_CURRENT)
WriteFile hFile, BBits(0), BInfo.bmiHeader.biSizeImage, bWritten, ByVal 0&
BFheader.bfSize = SetFilePointer(hFile, 0, 0, FILE_CURRENT)
Call SetFilePointer(hFile, 0, 0, FILE_BEGIN)
WriteFile hFile, BFheader.bfType, Len(BFheader.bfType), bWritten, ByVal 0&
Call ReverseWriteLong(hFile, bWritten, BFheader.bfSize)
WriteFile hFile, BFheader.bfReserved1, 2, bWritten, ByVal 0&
WriteFile hFile, BFheader.bfReserved2, 2, bWritten, ByVal 0&
Call ReverseWriteLong(hFile, bWritten, BFheader.bfOffBits)
closefile:
CloseHandle (hFile)
BitmapToFile = 0
End Function

Private Sub ReverseWriteLong(hFile As Long, ByRef bWritten As Long, ByVal DWORD As Long)
WriteFile hFile, loWord(DWORD), 2, bWritten, ByVal 0&
WriteFile hFile, hiWord(DWORD), 2, bWritten, ByVal 0&
End Sub

Private Function hiWord(ByVal DWORD As Long) As Integer
Dim hWord As Integer
Call CopyMemory(hWord, ByVal (VarPtr(DWORD) + 2), 2)
hiWord = hWord
End Function

Private Function loWord(ByVal DWORD As Long) As Integer
Dim lWord As Integer
Call CopyMemory(lWord, ByVal (VarPtr(DWORD)), 2)
loWord = lWord
End Function