GFDCToStdPicture/Mfrm.frm
VERSION 5.00
Begin VB.Form Mfrm
Caption = "Form1"
ClientHeight = 3255
ClientLeft = 60
ClientTop = 345
ClientWidth = 4695
LinkTopic = "Form1"
ScaleHeight = 3255
ScaleWidth = 4695
StartUpPosition = 3 'Windows‑Standard
Begin VB.PictureBox Picture2
AutoRedraw = ‑1 'True
AutoSize = ‑1 'True
Height = 540
Left = 60
Picture = "Mfrm.frx":0000
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 0
Top = 1200
Width = 540
End
Begin VB.PictureBox Picture1
AutoRedraw = ‑1 'True
Height = 540
Left = 4080
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 2
Top = 1200
Width = 540
End
Begin VB.CommandButton Command1
Caption = "Create VB Picture object ‑>"
Height = 375
Left = 1260
TabIndex = 1
Top = 1320
Width = 2175
End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2003, 2004 by Louis.
'
'NOTE: this project requires a reference to StdOle2.tbl.
'The whole GFDCToStdPicture() code is a manipulation of the code from the Microsoft article:
'Q161299 ‑ HOWTO Capture and Print the Screen, a Form, or Any Window,
'which should also be saved somewhere on this drive (except for downloadable version).
'
'Downloaded from www.louis‑coder.com.
'This code shows how to create a VB StdPicture object out of the content of any Windows
'device context. That conversion is usable if you want to save any drawn image or the
'Windows desktop for later displaying in a picture box.
'
'GFDCToStdPicture
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 BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground 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 OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'GFDCToStdPicture
'Private Type lPicture
'End Type
'GFDCToStdPicture
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
'GFDCToStdPicture
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
'GFDCToStdPicture
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
'GFDCToStdPicture
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'GFDCToStdPicture
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
'DEBUG
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Dim hDC2 As Long
'***DEBUG***
Private Sub Command1_Click()
'on error resume next
Dim hDC2Old As Long
Dim Temp As Long
Dim TempStdPicture As StdPicture
'begin
Picture1.ScaleMode = vbPixels
'If hDC2 = 0 Then
Call BitBlt(Picture1.hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture2.hDC, 0, 0, vbSrcCopy)
Picture1.Picture = Picture1.Image
'Else
' Set Picture1.Picture = Nothing
'End If
Me.AutoRedraw = True
' Do 'leak check ‑ ok, no leaks
' DoEvents
' hDC2 = CreateCompatibleDC(Picture1.hDC)
' hDC2Old = SelectObject(hDC2, Picture1.Picture.Handle)
' Set TempStdPicture = GFDCToStdPicture(hDC2, Picture1.ScaleWidth, Picture1.ScaleHeight) 'FindWindow("Shell_traywnd", "")
' Temp = SelectObject(hDC2, hDC2Old)
' Call DeleteObject(Temp)
' Call DeleteDC(Temp)
' Call DeleteObject(hDC2)
' Call DeleteDC(hDC2)
' 'Set TempStdPicture =
' 'Set Me.Picture = TempStdPicture
' Picture1.Font.Bold = True
' Picture1.Cls
' Picture1.Print "BLAH"
' Picture1.Font.Bold = False
' Loop
End Sub
'***END OF DEBUG***
Private Function GFDCToStdPicture(ByVal DC As Long, ByVal Width As Long, ByVal Height As Long) As StdPicture
'on error resume next 'returns a StdPicture structure that 'contains' an image from a memory DC; format: pixels
Dim BitmapHandle As Long
Dim BitmapHandleOld As Long
Dim PaletteHandle As Long
Dim PaletteHandleOld As Long
Dim ScreenRasterCaps As Long
Dim ScreenHasPalette As Long
Dim ScreenPaletteSize As Long
Dim LOGPALETTEVar As LOGPALETTE
Dim PicBmpVar As PicBmp
Dim lPictureVar As IPicture
Dim GUIDVar As GUID
Dim TempDC As Long
Dim Temp As Long
'
'NOTE: use this function to transfer images between memory DCs
'and VB picture boxes or forms.
'The whole code is a manipulation of a Microsoft example named:
'Q161299 ‑ HOWTO Capture and Print the Screen, a Form, or Any Window.
'
'preset
GUIDVar.Data1 = &H20400
GUIDVar.Data4(0) = &HC0
GUIDVar.Data4(7) = &H46
'begin
'create a temporary memory DC
TempDC = CreateCompatibleDC(0)
'create a bitmap and place it in the memory DC
BitmapHandle = CreateCompatibleBitmap(DC, Width, Height)
BitmapHandleOld = SelectObject(TempDC, BitmapHandle)
'get screen properties
ScreenRasterCaps = GetDeviceCaps(DC, RASTERCAPS)
ScreenHasPalette = ScreenRasterCaps And RC_PALETTE
ScreenPaletteSize = GetDeviceCaps(DC, SIZEPALETTE)
'if the screen has a palette then make a copy and realize it (tested, ok)
If (ScreenHasPalette) And (ScreenPaletteSize = 256) Then
'create a copy of the system palette
LOGPALETTEVar.palVersion = &H300
LOGPALETTEVar.palNumEntries = 256
Temp = GetSystemPaletteEntries(DC, 0, 256, LOGPALETTEVar.palPalEntry(0))
PaletteHandle = CreatePalette(LOGPALETTEVar)
'select the new palette into the memory DC and realize it
PaletteHandleOld = SelectPalette(TempDC, PaletteHandle, 0)
Temp = RealizePalette(TempDC)
End If
'copy the image into the memory DC
Call BitBlt(TempDC, 0, 0, Width, Height, DC, 0, 0, vbSrcCopy)
'remove the new copy of the image
BitmapHandle = SelectObject(TempDC, BitmapHandleOld)
'if the screen has a palette then get back the palette that was selected previously
If (ScreenHasPalette) And (ScreenPaletteSize = 256) Then
PaletteHandle = SelectPalette(TempDC, PaletteHandleOld, 0)
Call DeleteObject(PaletteHandle)
Call DeleteObject(PaletteHandleOld)
Call DeleteDC(TempDC)
Else
Call DeleteDC(TempDC)
End If
'
PicBmpVar.Size = Len(PicBmpVar)
PicBmpVar.Type = vbPicTypeBitmap
PicBmpVar.hBmp = BitmapHandle
PicBmpVar.hPal = PaletteHandle
'
Call OleCreatePictureIndirect(PicBmpVar, GUIDVar, 1, lPictureVar) '1 for system deletes picture when no longer needed
'
Set GFDCToStdPicture = lPictureVar
End Function
[END OF FILE]