' - Creates a bitmap type Picture object from a bitmap and palette
'
' hBmp
' - Handle to a bitmap
'
' hPal
' - Handle to a Palette
' - Can be null if the bitmap doesn't use a palette
'
' Returns
' - Returns a Picture object containing the bitmap
#If Win32 Then
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
ByVal hPal As Long) As Picture
Dim r As Long

#ElseIf Win16 Then
Public Function CreateBitmapPicture(ByVal hBmp As Integer, _
ByVal hPal As Integer) As Picture
Dim r As Integer

#End If
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types"
Dim IPic As IPicture
Dim IID_IDispatch As GUID
' Fill in with IDispatch Interface ID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill Pic with necessary parts
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = hPal ' Handle to palette (may be null)
End With
' Create Picture object
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
' Return the new Picture object
Set CreateBitmapPicture = IPic

End Function


' CaptureWindow
' - Captures any portion of a window
'
' hWndSrc
' - Handle to the window to be captured
'
' Client
' - If True CaptureWindow captures from the client area of the window
' - If False CaptureWindow captures from the entire window
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc
' - Specify the portion of the window to capture
' - Dimensions need to be specified in pixels
'
' Returns
' - Returns a Picture object containing a bitmap of the specified
' portion of the window that was captured
#If Win32 Then
Public Function CaptureWindow(ByVal hWndSrc As Long, _
ByVal Client As Boolean, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long

#ElseIf Win16 Then
Public Function CaptureWindow(ByVal hWndSrc As Integer, _
ByVal Client As Boolean, ByVal LeftSrc As Integer, _
ByVal TopSrc As Integer, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Integer
Dim hBmp As Integer
Dim hBmpPrev As Integer
Dim r As Integer
Dim hDCSrc As Integer
Dim hPal As Integer
Dim hPalPrev As Integer
Dim RasterCapsScrn As Integer
Dim HasPaletteScrn As Integer
Dim PaletteSizeScrn As Integer

#End If
Dim LogPal As LOGPALETTE
' Depending on the value of Client get the proper device context
If Client Then
hDCSrc = GetDC(hWndSrc) ' Get device context for client area
Else
hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire window
End If
' Create a memory device context for the copy process
hDCMemory = CreateCompatibleDC(hDCSrc)
' Create a bitmap and place it in the memory DC
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
' Get screen properties
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster capabilities
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette support
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of palette
' If the screen has a palette make a copy and realize it
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
' Create a copy of the system palette
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
' Select the new palette into the memory DC and realize it
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
' Copy the on-screen image into the memory DC
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
LeftSrc, TopSrc, vbSrcCopy)
' Remove the new copy of the the on-screen image
hBmp = SelectObject(hDCMemory, hBmpPrev)
' If the screen has a palette get back the palette that was selected
' in previously
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
' Release the device context resources back to the system
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
' Call CreateBitmapPicture to create a picture object from the bitmap
' and palette handles. Then return the resulting picture object.
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)

End Function


' CaptureScreen
' - Captures the entire screen
'
' Returns
' - Returns a Picture object containing a bitmap of the screen
Public Function CaptureScreen() As Picture
#If Win32 Then
Dim hWndScreen As Long
#ElseIf Win16 Then
Dim hWndScreen As Integer
#End If
' Get a handle to the desktop window
hWndScreen = GetDesktopWindow()
' Call CaptureWindow to capture the entire desktop give the handle and
' return the resulting Picture object
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _
Screen.Width Screen.TwipsPerPixelX, _
Screen.Height Screen.TwipsPerPixelY)

End Function


' CaptureForm
' - Captures an entire form including title bar and border
'
' frmSrc
' - The Form object to capture
' Returns
' - Returns a Picture object containing a bitmap of the entire form
Public Function CaptureForm(frmSrc As Form) As Picture
' Call CaptureWindow to capture the entire form given it's window
' handle and then return the resulting Picture object
Set CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, _
frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), _
frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))

End Function


' CaptureClient
' - Captures the client area of a form
'
' frmSrc
' - The Form object to capture
'
' Returns
' - Returns a Picture object containing a bitmap of the form's client
' area
Public Function CaptureClient(frmSrc As Form) As Picture
' Call CaptureWindow to capture the client area of the form given it's
' window handle and return the resulting Picture object
Set CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, _
frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), _
frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))

End Function


' CaptureActiveWindow
' - Captures the currently active window on the screen
'
' Returns
' - Returns a Picture object containing a bitmap of the active window
Public Function CaptureActiveWindow() As Picture
#If Win32 Then
Dim hWndActive As Long
Dim r As Long
#ElseIf Win16 Then
Dim hWndActive As Integer
Dim r As Integer
#End If
Dim RectActive As RECT
' Get a handle to the active/foreground window
hWndActive = GetForegroundWindow()
' Get the dimensions of the window
r = GetWindowRect(hWndActive, RectActive)
' Call CaptureWindow to capture the active window given it's handle and
' return the Resulting Picture object
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _
RectActive.Right - RectActive.Left, _
RectActive.Bottom - RectActive.Top)

End Function


' PrintPictureToFitPage
' - Prints a Picture object as big as possible
'
' Prn
' - Destination Printer object
'
' Pic
' - Source Picture object
Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
Const vbHiMetric As Integer = 8
Dim PicRatio As Double
Dim PrnWidth As Double
Dim PrnHeight As Double
Dim PrnRatio As Double
Dim PrnPicWidth As Double
Dim PrnPicHeight As Double
' Determine if picture should be printed in landscape or portrait and
' set the orientation
If Pic.Height >= Pic.Width Then
Prn.Orientation = vbPRORPortrait ' Taller than wide
Else
Prn.Orientation = vbPRORLandscape ' Wider than tall
End If
' Calculate device independent Width to Height ratio for picture
PicRatio = Pic.Width / Pic.Height
' Calculate the dimentions of the printable area in HiMetric
PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
' Calculate device independent Width to Height ratio for printer
PrnRatio = PrnWidth / PrnHeight
' Scale the output to the printable area
If PicRatio >= PrnRatio Then
' Scale picture to fit full width of printable area
PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, _
Prn.ScaleMode)
Else
' Scale picture to fit full height of printable area
PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, _
Prn.ScaleMode)
End If
' Print the picture using the PaintPicture method
Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight

End Sub

Related Posts

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.