GFMaskPrint/GFMaskPrint.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3375
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6075
   LinkTopic       =   "Form1"
   ScaleHeight     =   3375
   ScaleWidth      =   6075
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Test"
      Height          =   375
      Left            =   4140
      TabIndex        =   3
      Top             =   2820
      Width           =   1815
   End
   Begin VB.PictureBox PrintTargetPicture
      Height          =   2055
      Left            =   60
      Picture         =   "GFMaskPrint.frx":0000
      ScaleHeight     =   1995
      ScaleWidth      =   5835
      TabIndex        =   2
      Top             =   600
      Width           =   5895
   End
   Begin VB.PictureBox PrintMaskPicture
      AutoSize        =   ‑1 'True
      Height          =   450
      Left            =   600
      ScaleHeight     =   26
      ScaleMode       =   3 'Pixel
      ScaleWidth      =   26
      TabIndex        =   1
      Top             =   60
      Width           =   450
   End
   Begin VB.PictureBox PrintSourcePicture
      AutoSize        =   ‑1 'True
      BackColor       =   &H00FFFFFF&
      Height          =   450
      Left            =   60
      Picture         =   "GFMaskPrint.frx":4B146
      ScaleHeight     =   26
      ScaleMode       =   3 'Pixel
      ScaleWidth      =   26
      TabIndex        =   0
      Top             =   60
      Width           =   450
   End
   Begin VB.Label Label1
      Caption         =   "(Pointer from The Guitar)"
      Height          =   195
      Left            =   1140
      TabIndex        =   4
      Top             =   300
      Width           =   4815
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis.
'GFMaskPrint
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As LongByVal X As LongByVal Y As LongByVal nWidth As LongByVal nHeight As LongByVal hSrcDC As LongByVal xSrc As LongByVal ySrc As LongByVal dwRop As Long) As Long
'GFMaskPrint_CreateMaskPicture
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As LongByVal nHeight As LongByVal nPlanes As LongByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As LongByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As LongByVal hObject As Long) As Long
'
'NOTE: you can create a transparent bitmap using the GFMaskPrint function.
'The problem is that you need a mask picture for that, use GFMaskPrint_CreateMaskPicture()
'to automatically create a mask picture by defining one transparent color.
'

Private Function GFMaskPrint(ByVal PrintTargetPictureBox As ObjectByVal PrintTargetPictureXPos As LongByVal PrintTargetPictureYPos As LongByVal PrintSourcePictureBox As PictureBox, ByVal PrintMaskPictureBox As PictureBox) As Boolean
    On Error GoTo Error: 'function returns True if printing was successful, False if not
    Dim PrintMaskPictureScaleModeUnchanged As Integer
    '
    'NOTE: use this function to print transparent text, non‑rectangular pictures, etc.
    'The mask must consist of two colors only (black and white), everything that's white will be printed.
    'Print[Source/Mask] must have the picture to print placed at (0|0), and must have been made fit to
    'the picture's size.
    '
    PrintMaskPictureScaleModeUnchanged = PrintMaskPictureBox.ScaleMode
    PrintMaskPictureBox.ScaleMode = vbPixels 'important
    Call BitBlt(PrintTargetPictureBox.hdc, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hdc, 0, 0, vbSrcPaint)
    Call BitBlt(PrintSourcePictureBox.hdc, 0, 0, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintMaskPictureBox.hdc, 0, 0, vbMergePaint)
    Call BitBlt(PrintTargetPictureBox.hdc, PrintTargetPictureXPos, PrintTargetPictureYPos, PrintMaskPictureBox.ScaleWidth, PrintMaskPictureBox.ScaleHeight, PrintSourcePictureBox.hdc, 0, 0, vbSrcAnd)
    PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
    GFMaskPrint = True 'ok
    Exit Function
Error:
    If Not (PrintMaskPictureScaleModeUnchanged = 0) Then 'verify
        PrintMaskPictureBox.ScaleMode = PrintMaskPictureScaleModeUnchanged 'reset
    End If
    GFMaskPrint = False 'error
    Exit Function
End Function

Private Function GFMaskPrint_CreateMaskPicture(ByRef MaskSourcePictureBox As PictureBox, ByRef MaskTargetPictureBox As PictureBox, ByVal MaskTransparentColor As Long)
    'on error resume next 'this function does not work ( :‑(======== ??? )
    Dim MaskBitmapHandle As Long
    Dim MaskBitmapDC As Long
    'preset
    'NOTE: the scale modes are not reset (to hell with twips).
    MaskSourcePictureBox.ScaleMode = vbPixels
    MaskTargetPictureBox.ScaleMode = vbPixels
    'begin
    MaskBitmapHandle = CreateBitmap(MaskTargetPictureBox.ScaleWidth, MaskTargetPictureBox.ScaleHeight, 1, 1, 0&)
    MaskBitmapDC = CreateCompatibleDC(MaskTargetPictureBox.hdc)
    Call SetBkColor(MaskBitmapDC, MaskTransparentColor)
    Call SelectObject(MaskBitmapDC, MaskBitmapHandle)
    Call BitBlt(MaskBitmapDC, 0, 0, MaskTargetPictureBox.ScaleWidth, MaskTargetPictureBox.ScaleHeight, MaskSourcePictureBox.hdc, 0, 0, vbSrcInvert)
    Call BitBlt(MaskTargetPictureBox.hdc, 0, 0, MaskTargetPictureBox.ScaleWidth, MaskTargetPictureBox.ScaleHeight, MaskBitmapDC, 0, 0, vbSrcCopy)
End Function

Private Sub Command1_Click()
    'on error resume next
    Debug.Print PrintMaskPicture.ScaleMode
    Debug.Print GFMaskPrint(PrintTargetPicture, 10, 10, PrintSourcePicture, PrintMaskPicture)
    Debug.Print PrintMaskPicture.ScaleMode
    Call GFMaskPrint_CreateMaskPicture(PrintSourcePicture, PrintMaskPicture, RGB(255, 255, 255))
End Sub


[END OF FILE]